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

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