Télécharger la plaquette Cast3M


fr en

Télécharger prjdru.eso

Retour à la liste

Numérotation des lignes : 

prjdru

  1. C PRJDRU    SOURCE    FANDEUR   22/05/02    21:15:29     11359          
  2.       SUBROUTINE PRJDRU(SSTAR,SELAS,PENTE,IBOU,SI,DEPS,EPST,
  3.      .   EPSTAR,ITER,SN,DHOOK,AM,A,BM,XMAT,YUNG,XNU,LAPOIN,KERRE,
  4.      & ecou,necou)
  5. *
  6.       IMPLICIT INTEGER(I-N)
  7.       IMPLICIT REAL *8(A-H,O-Z)
  8.       DIMENSION AM(*),A(*),BM(*),XMAT(*),DHOOK(*)
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. *
  13.       SEGMENT ECOU
  14. ***     COMMON/ECOU/TEST,ALFAH,
  15.        REAL*8 TEST, ALFAH,
  16.      1 HPAS,TEMPS,COVNMS(6),VECPRO(9),VALPRO(6),
  17.      2 CVNMSD(12),STOT(6),SIGEL(6),DSIGP(6),SIGT(6),W1(6),W2(6),
  18.      1 DALPHA(6),EPSPLA(6),E(12),XINV(3),
  19.      2 SIPLAD(6),DSIGP0(6),TET,TETI
  20.       ENDSEGMENT
  21. C      COMMON/ECOU/TEST,ALFAH,
  22. C     . HPAS,TEMPS,COVNMS(6),VECPRO(9),VALPRO(6),
  23. C     . CVNMSD(12),STOT(6),SIGEL(6),DSIGP(6),SIGT(6),W1(6),W2(6),
  24. C     . DALPHA(6),EPSPLA(6),E(12),XINV(3),
  25. C     . SIPLAD(6),DSIGP0(6),TET,TETI
  26. *
  27.       SEGMENT NECOU
  28. *      COMMON/NECOU/NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  29.        INTEGER NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  30.      . ITYP,JFOUR,IFLUAG,
  31.      . ICINE,ITHER,IFLUPL,ICYCL,IBI,
  32.      . JFLUAG,LEGAUS,LFLUAG,
  33.      . IRELAX,JNTRIN,MFLUAG,JELEM,JGRDEF
  34.       ENDSEGMENT
  35. C      COMMON/NECOU/NCOURB,IPLAST,IT,IMAPLA,ISOTRO,
  36. C     . ITYP,JFOUR,IFLUAG,
  37. C     . ICINE,ITHER,IFLUPL,ICYCL,IBI,
  38. C     . JFLUAG,LEGAUS,LFLUAG,
  39. C     . IRELAX,JNTRIN,MFLUAG,JELEM,JGRDEF
  40.  
  41.       REAL*8   DDOT
  42.       EXTERNAL DDOT
  43. *
  44.       DATA COEPT/1.D-3/
  45.       DATA ITMAX/25/
  46. *
  47. *  QUELQUES INITIALISATIONS
  48. *
  49.       IIMPI0=IIMPI
  50.       JEBOUC=0
  51. 2020  JEBOUC=JEBOUC+1
  52.       KERRE=0
  53.       LESN0 =0
  54.       LAPOIN=0
  55.       CALL ZDANUL(AM,36)
  56.       CALL ZDANUL(W2,6)
  57.       CALL ZDANUL(EPSPLA,6)
  58.       XMATE =XMAT(1)
  59.       XMATM =XMAT(2)
  60.       XMATKL=XMAT(3)
  61.       XMATC =XMAT(4)
  62.       XMATD =XMAT(5)
  63.       PEPSI =SQRT(2.D0*XMATC*XMATC+XMATD*XMATD)
  64.       PENTE =XMAT(9)*PEPSI
  65.       PENTF=PENTE
  66. *
  67.       IF(IIMPI.EQ.15) THEN
  68.       WRITE(IOIMP,77991) YUNG,XNU,ITYP,IMAPLA,PEPSI
  69. 77991 FORMAT('0 PRJDRU  YUNG=',1PE12.5,2X,'XNU=',1PE12.5/
  70.      .       2X,'ITYP=',I4,2X,'IMAPLA=',I4,2X,'PEPSI=',1PE12.5/)
  71.       WRITE(IOIMP,77992) (XMAT(IJ),IJ=1,9)
  72. 77992 FORMAT('0 PRJDRU  XMAT ' /(3(1X,1PE12.5)))
  73.       WRITE(IOIMP,77995) SSTAR,SELAS,EPSTAR
  74. 77995 FORMAT('0 PRJDRU   SSTAR=',1PE12.5,2X,'SELAS=',1PE12.5,2X,
  75.      .       'EPSTAR=',1PE12.5/)
  76.       ENDIF
  77. *
  78. *     CALCUL DE LA MATRICE DE HOOKE ( ISOTROPE ONLY | )
  79. *
  80.       CALL HOOINC(DHOOK,YUNG,XNU,ITYP)
  81. *
  82.       GO TO (101,102,103,104,105,106,107,108,109),ITYP
  83.   101 CONTINUE
  84.       DO IA=1,3
  85.         AM((IA-1)*6+IA)   =1.D0
  86.         AM((IA-1)*6+21+IA)=3.0D0
  87.         W2(IA)=1.D0
  88.       ENDDO
  89.       AM(2)=-0.5D0
  90.       AM(3)=-0.5D0
  91.       AM(7)=-0.5D0
  92.       AM(9)=-0.5D0
  93.       AM(13)=-0.5D0
  94.       AM(14)=-0.5D0
  95.       GO TO 200
  96.   102 CONTINUE
  97. *         ON SAUVE D COMPACTE SUR 10 VALEURS DANS CVNMSD
  98.       CALL SHIFTD(DHOOK,CVNMSD,10)
  99.       CALL ZDANUL(DHOOK,36)
  100.       DHOOK(1)=CVNMSD(1)
  101.       DHOOK(2)=CVNMSD(2)
  102.       DHOOK(7)=CVNMSD(3)
  103.       DHOOK(8)=CVNMSD(4)
  104.       DHOOK(15)=CVNMSD(5)
  105.       DHOOK(22)=CVNMSD(6)
  106.       DHOOK(23)=CVNMSD(7)
  107.       DHOOK(28)=CVNMSD(8)
  108.       DHOOK(29)=CVNMSD(9)
  109.       DHOOK(36)=CVNMSD(10)
  110.       DO IA=1,2
  111.         AM(6*(IA-1)+IA)=ALFAH
  112.         AM(6*(IA-1)+21+IA)=1.D0
  113.         W2(3+IA)=1.D0
  114.       ENDDO
  115.       AM(2)=-0.5D0*ALFAH
  116.       AM(7)=-0.5D0*ALFAH
  117.       AM(15)=3.0D0*ALFAH
  118.       AM(23)=-0.5D0
  119.       AM(28)=-0.5D0
  120.       AM(36)=3.0D0
  121.       GO TO 200
  122.   103 CONTINUE
  123.       CALL SHIFTD(DHOOK,CVNMSD,10)
  124.       CALL ZDANUL(DHOOK,36)
  125.       DHOOK(1)=CVNMSD(1)
  126.       DHOOK(2)=CVNMSD(2)
  127.       DHOOK(7)=CVNMSD(3)
  128.       DHOOK(8)=CVNMSD(4)
  129.       DHOOK(15)=CVNMSD(5)
  130.       DHOOK(22)=CVNMSD(6)
  131.       DHOOK(23)=CVNMSD(7)
  132.       DHOOK(28)=CVNMSD(8)
  133.       DHOOK(29)=CVNMSD(9)
  134.       DHOOK(36)=CVNMSD(10)
  135.       AM(1)= 1.D0
  136.       AM(2)=-0.5D0
  137.       AM(7)=-0.5D0
  138.       AM(8)= 1.D0
  139.       AM(15)=3.0D0
  140.       W2(1)= 1.D0
  141.       W2(2)= 1.D0
  142.       GO TO 200
  143.   104 CONTINUE
  144.       AM(15)=1.D0
  145.       W2(3)=1.D0
  146.       GO TO 200
  147.   105 CONTINUE
  148.       AM(1)=0.5D0*(COVNMS(2)+COVNMS(3))
  149.       AM(8)=0.5D0*(COVNMS(1)+COVNMS(3))
  150.       AM(15)=0.5D0*(COVNMS(2)+COVNMS(1))
  151.       AM(2)=-0.5D0*COVNMS(3)
  152.       AM(3)=-0.5D0*COVNMS(2)
  153.       AM(7)=-0.5D0*COVNMS(3)
  154.       AM(9)=-0.5D0*COVNMS(1)
  155.       AM(13)=-0.5D0*COVNMS(2)
  156.       AM(14)=-0.5D0*COVNMS(1)
  157.       AM(22)=-0.5D0*COVNMS(4)
  158.       AM(29)=-0.5D0*COVNMS(5)
  159.       AM(36)=-0.5D0*COVNMS(6)
  160.       DO IB=1,3
  161.         W2(IB)=1.D0
  162.       ENDDO
  163.       GO TO 200
  164.   106 CONTINUE
  165.       AM(1) =1.D0
  166.       AM(8) =1.D0
  167.       AM(15)=1.D0
  168.       AM(2)=-0.5D0
  169.       AM(3)=-0.5D0
  170.       AM(7)=-0.5D0
  171.       AM(9)=-0.5D0
  172.       AM(13)=-0.5D0
  173.       AM(14)=-0.5D0
  174.       AM(22)=3.0D0
  175.       W2(1)=1.D0
  176.       W2(2)=1.D0
  177.       W2(3)=1.D0
  178.       GO TO 200
  179.   107 CONTINUE
  180.       AM(1)=ALFAH
  181.       AM(22)=1.D0
  182.       W2(4)=1.D0
  183.       GO TO 200
  184.   108 CONTINUE
  185.       AM(1)=1.D0
  186.       W2(1)=1.D0
  187.       GO TO 200
  188.   109 CONTINUE
  189. *
  190.   200 CONTINUE
  191.       TST=TEST*0.3333333333D0*(DHOOK(1)+DHOOK(8)+DHOOK(15))*COEPT
  192.       TST10=TST*1.D1
  193.       IF(IIMPI.EQ.15) WRITE(IOIMP,77883) TST,DHOOK(1),DHOOK(8),
  194.      .                 DHOOK(15),TEST,COEPT
  195. 77883 FORMAT('0   PRJDRU - TST=',1PE12.5/2X,
  196.      . 'DHOOK(1)=',1PE12.5,2X,'DHOOK(8)=',1PE12.5,2X,
  197.      . 'DHOOK(15)=',1PE12.5/'0   TEST=',1PE12.5,2X,
  198.      . 'COEPT=',1PE12.5/)
  199. *
  200. *  INITIALISATIONS AVANT ITERATIONS
  201. *
  202.       ITER =0
  203.       EPSTA0 = EPSTAR/PEPSI
  204.       EPST = EPSTA0
  205.       SN   = XMATKL+PENTE*EPSTA0
  206. *                                     AM  24/5/93    TEST SUR SN
  207.       IF(SN.LT.0.D0) THEN
  208.         LESN0=1
  209.         SN = 0.D0
  210.         PENTF=0.D0
  211.       ENDIF
  212.       DEPS =0.D0
  213.       DEPSI=0.D0
  214.       CALL SHIFTD(STOT,SIGEL,6)
  215.       CALL CKRIT(IMAPLA,SIGEL,ITYP,XMAT,ALFAH,COVNMS,XINV,SI)
  216.       SJ1=XINV(1)
  217.       SJ2=XINV(2)
  218.       IF(IIMPI.EQ.15) THEN
  219.       WRITE(IOIMP,77993) (SIGEL(IJ),IJ=1,IBOU)
  220. 77993 FORMAT('0 PRJDRU  SIGEL ' /(6(1X,1PE12.5)))
  221.       WRITE(IOIMP,77994) SN,SI,SJ1,SJ2
  222. 77994 FORMAT('0 PRJDRU  SN=',1PE12.5,2X,'SI=',1PE12.5,2X,
  223.      .        'SJ1=',1PE12.5,2X,'SJ2=',1PE12.5)
  224.       ENDIF
  225. *
  226. *                -------------------------------
  227. *                |   LES ITERATIONS INTERNES   |
  228. *                -------------------------------
  229.   555 CONTINUE
  230.       ITER=ITER+1
  231.       IF(IIMPI.EQ.15) WRITE(IOIMP,77886) ITER
  232. 77886 FORMAT('0  >>>>>>>>>>> PRJDRU - ITER =',I4/)
  233. *
  234. *                                     AM  24/5/93    TEST SUR SJ2
  235.       IF(IIMPI.EQ.15) WRITE(IOIMP,71886) SJ2,TST10
  236. 71886 FORMAT('0   SJ2=',1PE12.5,2X,'TST10=',1PE12.5/)
  237.       IF(SJ2.LT.TST10) GO TO 6
  238. *
  239. 1108  CONTINUE
  240.       DO IM=1,IBOU
  241.         DALPHA(IM) = SIGEL(IM)
  242.       ENDDO
  243.       CALL MULMAT(W1,AM,SIGEL,6,1,6)
  244.       IF(IIMPI.EQ.15) WRITE(IOIMP,72677) (W1(IJ),IJ=1,6)
  245. 72677 FORMAT(1X,'  W1  '/(6(1X,1PE12.5)))
  246.       ELTB=XMATD/SJ2
  247.       ELT =XMATM/SJ2
  248.       CALL AEQBPC(SIPLAD,W1,W2,ELTB,XMATC,6)
  249.       IF(IIMPI.EQ.15) WRITE(IOIMP,73677) (SIPLAD(IJ),IJ=1,6)
  250. 73677 FORMAT(1X,' SIPLAD  '/(6(1X,1PE12.5)))
  251.       CALL AEQBPC(W1,W1,W2,ELT,XMATE,6)
  252.       IF(IIMPI.EQ.15) WRITE(IOIMP,73674) (W1(IJ),IJ=1,6)
  253. 73674 FORMAT(1X,'  W1     '/(6(1X,1PE12.5)))
  254.       CALL MULMAT(DSIGP0,DHOOK,SIPLAD,6,1,6)
  255.       IF(IIMPI.EQ.15) WRITE(IOIMP,73675) (DSIGP0(IJ),IJ=1,6)
  256. 73675 FORMAT(1X,' DSIGP0     '/(6(1X,1PE12.5)))
  257.       ELT1=DDOT(IBOU,W1,1,DSIGP0,1)
  258.       DEPSI=(SI-SN)/(ELT1+PENTF+1.E-20)
  259.       DEPS = DEPS+DEPSI
  260.       IF(IIMPI.EQ.15) WRITE(IOIMP,77888) DEPSI,DEPS
  261. 77888 FORMAT('0   PRJDRU - DEPSI=',1PE12.5,2X,'DEPS=',1PE12.5/)
  262.       IF(DEPS.LT.0.D0) GO TO 5
  263.       EPST = EPSTA0+DEPS
  264.       IF(LESN0.EQ.0) SN=XMATKL+PENTE*EPST
  265.       IF(IIMPI.EQ.15) WRITE(IOIMP,77812) XMATKL,PENTE,EPST,SN
  266. 77812 FORMAT('0   PRJDRU - XMATKL',1PE12.5,2X,'PENTE=',1PE12.5,
  267.      .     2X,'EPST=',1PE12.5,2X,'SN=',1PE12.5/)
  268. *
  269. *                                      AM  24/5/93    TEST SUR SN
  270.       IF(SN.LT.0.D0) THEN
  271.         SN=0.D0
  272.         PENTF=0.D0
  273.         LESN0=1
  274. *                                      AM  12/8/93   ON REMBOBINE
  275.         DEPS = DEPS-DEPSI
  276.         ITER=ITER-1
  277.         IF(IIMPI.EQ.15) WRITE(IOIMP,71108)
  278. 71108   FORMAT('0  ******  PRJDRU - ON REMBOBINE '/)
  279.         GO TO 1108
  280.       ENDIF
  281.       DO I=1,IBOU
  282.         EPSPLA(I)=EPSPLA(I)+SIPLAD(I)*DEPSI
  283.       ENDDO
  284.       CALL AEQBPC(SIGEL,SIGEL,DSIGP0,1.D0,-DEPSI,6)
  285. *
  286. *   PETITE MODIF  19/8/92
  287. *
  288.       IF(MOD(ITER,5).EQ.0) THEN
  289.         DO IM=1,IBOU
  290.           SIGEL(IM)=(SIGEL(IM)+DALPHA(IM))*0.5D0
  291.         ENDDO
  292.       ENDIF
  293.       CALL CKRIT(IMAPLA,SIGEL,ITYP,XMAT,ALFAH,COVNMS,XINV,SI)
  294.       SJ1=XINV(1)
  295.       SJ2=XINV(2)
  296. *                                      AM  24/5/93
  297. *   SI XMATE=0   PAS DE PB DE SOMMET
  298. *   SINON, SI ON DEPASSE LE SOMMET, ON PROJETTE DESSUS
  299. *
  300.       IF(XMATE.EQ.0.D0) GO TO 210
  301.       XI1LIM=SN/XMATE
  302.       IF(IIMPI.EQ.15) WRITE(IOIMP,77811) SJ1,SN,XI1LIM,SJ2
  303. 77811 FORMAT('0   PRJDRU - SJ1=',1PE12.5,2X,' SN =',1PE12.5,
  304.      .       2X,'XI1LIM=',1PE12.5,2X,'SJ2=',1PE12.5/)
  305.       IF(SJ1.GT.XI1LIM) GO TO 6
  306.  210  CONTINUE
  307.       STST=ABS(SI-SN)
  308. *
  309.       IF(IIMPI.EQ.15) THEN
  310.       WRITE(IOIMP,77887) SI,SN,STST,TST,EPST
  311. 77887 FORMAT('0   PRJDRU - SI=',1PE12.5,2X,'SN=',1PE12.5,2X,
  312.      .  'STST=',1PE12.5,2X,'TST=',1PE12.5/2X,'EPST=',1PE12.5)
  313.       WRITE(IOIMP,77677) (SIGEL(IJ),IJ=1,IBOU)
  314. 77677 FORMAT(1X,'NOUVELLE SOLUTION'/(6(1X,1PE12.5)))
  315.       WRITE(IOIMP,71677) (EPSPLA(IJ),IJ=1,IBOU)
  316. 71677 FORMAT(1X,'NOUVELLE DEF PLA'/(6(1X,1PE12.5)))
  317.       ENDIF
  318. *
  319.       IF(STST.LE.TST)   GO TO 3
  320.       IF(ITER.GT.ITMAX) GO TO 4
  321.       GO TO 555
  322. *
  323. *     PROJECTION AU SOMMET
  324. *
  325.   6   CONTINUE
  326.       IF(IIMPI.EQ.15) WRITE(IOIMP,77387)
  327. 77387 FORMAT('0   PRJDRU - ON VA PROJETTER AU SOMMET ')
  328.       CALL SOMDRU(IBOU,SI,DEPS,EPST,EPSTAR,SN,XMAT,YUNG,
  329.      .            XNU,PENTF,KERRE,ecou,necou)
  330.       LAPOIN=1
  331.       GO TO 33
  332. *
  333.     5 CONTINUE
  334.       KERRE=1
  335.       GO TO 34
  336.     4 CONTINUE
  337.       KERRE=2
  338.    34 CONTINUE
  339.       IF (JEBOUC.EQ.1) THEN
  340.         IIMPI=15
  341.         GO TO 2020
  342.       ELSE
  343.         IIMPI=IIMPI0
  344.       ENDIF
  345.     3 CONTINUE
  346.       IF(IIMPI.EQ.15) WRITE(IOIMP,66554) (EPSPLA(IB),IB=1,IBOU)
  347. 66554 FORMAT('0 SORTIE DE PRJDRU  - EPSPLA ' /1X,6(1X,1PE12.5)/)
  348.       IF(IIMPI.EQ.15) WRITE(IOIMP,61554) DEPS,EPST
  349. 61554 FORMAT('0 SORTIE DE PRJDRU  - DEPS = ',1PE12.5,2X,'EPST=',
  350.      . 1PE12.5)
  351.       DEPS=DEPS*PEPSI
  352.       EPST=EPST*PEPSI
  353.    33 CONTINUE
  354.       IF(ITYP.EQ.2.OR.ITYP.EQ.3) CALL ZDANUL(DHOOK,36)
  355.       IF(ITYP.EQ.2.OR.ITYP.EQ.3) CALL SHIFTD(CVNMSD,DHOOK,10)
  356.  
  357. c      RETURN
  358.       END
  359.  
  360.  
  361.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales