Télécharger la plaquette Cast3M


fr en

Télécharger ccgtsu.eso

Retour à la liste

Numérotation des lignes : 

ccgtsu

  1. C CCGTSU    SOURCE    PV        22/04/22    21:15:04     11344          
  2.       SUBROUTINE CCGTSU(LCOF,NOMLOI,
  3.      $     FC,
  4.      $     IMPR,IRET)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.       IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM         : CCGTSU
  9. C DESCRIPTION : Calcul de la loi de comportement aux points de Gauss :
  10. C               Tension de surface
  11. C
  12. C
  13. C LANGAGE     : ESOPE
  14. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C               mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES          :
  18. C APPELE PAR       :
  19. C***********************************************************************
  20. C ENTREES            :
  21. C ENTREES/SORTIES    :
  22. C SORTIES            : -
  23. C TRAVAIL            :
  24. C***********************************************************************
  25. C VERSION    : v1, 17/01/07, version initiale
  26. C HISTORIQUE : v1, 17/01/07, création
  27. C HISTORIQUE :
  28. C HISTORIQUE :
  29. C***********************************************************************
  30. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  31. C en cas de modification de ce sous-programme afin de faciliter
  32. C la maintenance !
  33. C***********************************************************************
  34.  
  35. -INC PPARAM
  36. -INC CCOPTIO
  37. -INC CCREEL
  38. -INC TNLIN      
  39. *-INC SMCHAEL
  40.       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM,N1
  41.       POINTEUR FC.MCHEVA
  42.       POINTEUR LCOF.LCHEVA
  43.       POINTEUR JMAJAC.MCHEVA
  44.       POINTEUR JMIJAC.MCHEVA
  45.       POINTEUR JDTJAC.MCHEVA
  46.       POINTEUR JMAREG.MCHEVA
  47.       POINTEUR JPC.MCHEVA
  48.       POINTEUR JTS.MCHEVA
  49.       CHARACTER*8 NOMLOI
  50.       INTEGER ICOF
  51. *
  52. -INC TMXMAT
  53.       POINTEUR JAC.MXMAT,JT.MXMAT
  54.       POINTEUR G.MXMAT
  55.       POINTEUR IG.MXMAT
  56.       POINTEUR JPT.MXMAT
  57.       POINTEUR JPTJT.MXMAT
  58. *
  59.       LOGICAL LBID
  60.       INTEGER LAXSP
  61.       REAL*8 DEUPI,QUATPI,XR
  62.       REAL*8 DETG(1)
  63.       PARAMETER (DEUPI=2.D0*XPI,QUATPI=4.D0*XPI)
  64. *
  65.       INTEGER IMPR,IRET
  66. *
  67. * Executable statements
  68. *
  69.       IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans ccgtsu'
  70. C      IF (.NOT.(IDIM.EQ.1)) THEN
  71. C         WRITE(IOIMP,*) 'IDIM=',IDIM,' ?'
  72. C         GOTO 9999
  73. C      ENDIF
  74.       NLFC=FC.WELCHE(/6)
  75.       NPFC=FC.WELCHE(/5)
  76.       ICOF=0
  77. *
  78. *     Récupération du coefficent de tension de surface
  79. *
  80.       ICOF=ICOF+1
  81.       JTS =LCOF.LISCHE(ICOF)
  82.       NLTS=JTS.WELCHE(/6)
  83.       NPTS=JTS.WELCHE(/5)
  84. *
  85.       ICOF=ICOF+1
  86.       JMAJAC=LCOF.LISCHE(ICOF)
  87.       NLJA=JMAJAC.WELCHE(/6)
  88.       NPJA=JMAJAC.WELCHE(/5)
  89.       IREF=JMAJAC.WELCHE(/4)
  90.       IREL=JMAJAC.WELCHE(/3)
  91. *
  92.       IF (IREL.NE.IDIM) THEN
  93.          WRITE(IOIMP,*) 'Erreur dims JMAJAC'
  94.          GOTO 9999
  95.       ENDIF
  96. *
  97.       ICOF=ICOF+1
  98.       ICOF=ICOF+1
  99.       ICOF=ICOF+1
  100. *
  101. *!      WRITE(IOIMP,*) 'IFOMOD=',IFOMOD
  102.       IF (IFOMOD.EQ.0.OR.IFOMOD.EQ.4) THEN
  103. *!         WRITE(IOIMP,*) 'MODE AXISYMETRIQUE !!!!!!'
  104.          LAXSP=1
  105.       ELSEIF (IFOMOD.EQ.5) THEN
  106. *!         WRITE(IOIMP,*) 'MODE SPHERIQUE !!!!!!'
  107.          LAXSP=2
  108.       ELSE
  109. *!         WRITE(IOIMP,*) 'MODE PLAN !!!!!!'
  110.          LAXSP=0
  111.       ENDIF
  112. *!      WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  113. *!      WRITE(IOIMP,*) 'LAXSP=',LAXSP
  114. *
  115.       IF (LAXSP.GT.0) THEN
  116.          ICOF=ICOF+1
  117.          ICOF=ICOF+1
  118.          JPC=LCOF.LISCHE(ICOF)
  119.          NLPC=JPC.WELCHE(/6)
  120.          NPPC=JPC.WELCHE(/5)
  121.          IF (((NLPC.NE.1).AND.(NLPC.NE.NLFC)).OR.
  122.      $        ((NPPC.NE.1).AND.(NPPC.NE.NPFC))) THEN
  123.             WRITE(IOIMP,*) 'Erreur dims JPC'
  124.             GOTO 9999
  125.          ENDIF
  126.       ELSE
  127.          JPC=0
  128.          NLPC=0
  129.          NPPC=0
  130.       ENDIF
  131. *
  132. * Objets temporaires
  133. *
  134.       LDIM1=IREL
  135.       LDIM2=IREF
  136.       SEGINI,JAC
  137.       SEGINI,JPT
  138.       LDIM1=IREF
  139.       LDIM2=IREL
  140.       SEGINI,JT
  141.       LDIM1=IREF
  142.       LDIM2=IREF
  143.       SEGINI,G
  144.       SEGINI,IG
  145.       LDIM1=IREL
  146.       LDIM2=IREL
  147.       SEGINI,JPTJT
  148. *
  149.       DO ILFC=1,NLFC
  150.          IF (NLTS.EQ.1) THEN
  151.             ILTS=1
  152.          ELSE
  153.             ILTS=ILFC
  154.          ENDIF
  155.          IF (NLJA.EQ.1) THEN
  156.             ILJA=1
  157.          ELSE
  158.             ILJA=ILFC
  159.          ENDIF
  160.          IF (NLPC.EQ.1) THEN
  161.             ILPC=1
  162.          ELSE
  163.             ILPC=ILFC
  164.          ENDIF
  165.  
  166.  
  167.          DO IPFC=1,NPFC
  168.             IF (NPTS.EQ.1) THEN
  169.                IPTS=1
  170.             ELSE
  171.                IPTS=IPFC
  172.             ENDIF
  173.             IF (NPJA.EQ.1) THEN
  174.                IPJA=1
  175.             ELSE
  176.                IPJA=IPFC
  177.             ENDIF
  178.             IF (NPPC.EQ.1) THEN
  179.                IPPC=1
  180.             ELSE
  181.                IPPC=IPFC
  182.             ENDIF
  183. *
  184. * Valeur du coefficient
  185. *
  186.             IF (JTS.NE.0) THEN
  187.                XTS=JTS.WELCHE(1,1,1,1,IPTS,ILTS)
  188.             ENDIF
  189. *
  190. * Première coordonnée
  191. *
  192.             IF (JPC.NE.0) THEN
  193.                XR=JPC.WELCHE(1,1,1,1,IPPC,ILPC)
  194.             ENDIF
  195. *
  196. * Copie du jacobien
  197. *
  198.             CALL MAMA(JMAJAC.WELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
  199.      $           'COPIE   ',
  200.      $           JAC.XMAT,IREL,IREF,
  201.      $           IMPR,IRET)
  202.             IF (IRET.NE.0) GOTO 9999
  203. C            SEGPRT,JAC
  204. *
  205. * Calcul de la métrique G
  206. *
  207. *     Calcul de Jt
  208.             CALL MAMA(JAC.XMAT,IREL,IREF,
  209.      $           'TRANSPOS',JT.XMAT,IREF,IREL,
  210.      $           IMPR,IRET)
  211.             IF (IRET.NE.0) GOTO 9999
  212. *     Calcul de G=JtJ
  213.             CALL MAMAMA(JT.XMAT,IREF,IREL,JAC.XMAT,IREL,IREF,
  214.      $           'FOIS    ',G.XMAT,IREF,IREF,
  215.      $           IMPR,IRET)
  216.             IF (IRET.NE.0) GOTO 9999
  217. *
  218. * Calcul de l'inverse, du déterminant et trace de l'inverse
  219. *
  220.             LBID=.FALSE.
  221.             CALL GEOLI2(IREF,1,1,G.XMAT,IG.XMAT,DETG,LBID,IMPR,IRET)
  222.             IF (IRET.NE.0) GOTO 9999
  223.             SDETG=SQRT(DETG(1))
  224. *     Calcul de JPT=J (JtJ)-1
  225.             CALL MAMAMA(JAC.XMAT,IREL,IREF,IG.XMAT,IREF,IREF,
  226.      $           'FOIS    ',JPT.XMAT,IREL,IREF,
  227.      $           IMPR,IRET)
  228.             IF (IRET.NE.0) GOTO 9999
  229. *     Calcul de JPT=J (JtJ)-1
  230.             CALL MAMAMA(JPT.XMAT,IREL,IREF,JT.XMAT,IREF,IREL,
  231.      $           'FOIS    ',JPTJT.XMAT,IREL,IREL,
  232.      $           IMPR,IRET)
  233.             IF (IRET.NE.0) GOTO 9999
  234. *
  235. * Calcul de la fonctionnelle
  236. *
  237.             IF (NOMLOI.EQ.'TSUF    ') THEN
  238.                CONTRI=XTS*SDETG
  239.                IF (LAXSP.EQ.1) THEN
  240.                   CONTRI=CONTRI*2.D0*XPI*XR
  241.                ELSEIF (LAXSP.EQ.2) THEN
  242.                   CONTRI=CONTRI*4.D0*XPI*XR*XR
  243.                ENDIF
  244. *
  245. * Calcul du résidu
  246. *
  247.             ELSEIF (NOMLOI(1:4).EQ.'TSUR') THEN
  248.                CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  249.                IF (IRET.NE.0) GOTO 9999
  250.                CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  251.                IF (IRET.NE.0) GOTO 9999
  252.                IF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)) THEN
  253.                   IF (LAXSP.EQ.1) THEN
  254.                      CONTRI=XTS*2.D0*XPI*SDETG
  255.                   ELSEIF (LAXSP.EQ.2) THEN
  256.                      CONTRI=XTS*8.D0*XPI*XR*SDETG
  257.                   ELSE
  258.                      WRITE(IOIMP,*) 'LAXSP=',LAXSP
  259.                      GOTO 9999
  260.                   ENDIF
  261.                ELSE
  262.                   CONTRI=XTS*SDETG*JPT.XMAT(IDIM1,IDIM2)
  263.                   IF (LAXSP.EQ.1) THEN
  264.                      CONTRI=CONTRI*DEUPI*XR
  265.                   ELSEIF (LAXSP.EQ.2) THEN
  266.                      CONTRI=CONTRI*QUATPI*XR*XR
  267.                   ENDIF
  268.                ENDIF
  269. *
  270. * Calcul du jacobien
  271. *
  272.             ELSEIF (NOMLOI(1:4).EQ.'TSUJ') THEN
  273.                CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  274.                IF (IRET.NE.0) GOTO 9999
  275.                CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  276.                IF (IRET.NE.0) GOTO 9999
  277.                CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
  278.                IF (IRET.NE.0) GOTO 9999
  279.                CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
  280.                IF (IRET.NE.0) GOTO 9999
  281.                IF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)
  282.      $              .AND.(IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  283.                   IF (LAXSP.EQ.2) THEN
  284.                      CONTRI=XTS*8.D0*XPI*SDETG
  285.                   ELSE
  286.                      WRITE(IOIMP,*) 'LAXSP=',LAXSP
  287.                      WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  288.                      GOTO 9999
  289.                   ENDIF
  290.                ELSEIF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)) THEN
  291.                   IF (LAXSP.GE.1) THEN
  292.                      CONTRI=XTS*DEUPI*SDETG*JPT.XMAT(IDIM3,IDIM4)
  293.                      IF (LAXSP.EQ.2) THEN
  294.                         CONTRI=CONTRI*4.D0*XR
  295.                      ENDIF
  296.                   ELSE
  297.                      WRITE(IOIMP,*) 'LAXSP=',LAXSP
  298.                      WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  299.                      GOTO 9999
  300.                   ENDIF
  301.                ELSEIF ((IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  302.                   IF (LAXSP.GE.1) THEN
  303.                      CONTRI=XTS*DEUPI*SDETG*JPT.XMAT(IDIM1,IDIM2)
  304.                      IF (LAXSP.EQ.2) THEN
  305.                         CONTRI=CONTRI*4.D0*XR
  306.                      ENDIF
  307.                   ELSE
  308.                      WRITE(IOIMP,*) 'LAXSP=',LAXSP
  309.                      WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  310.                      GOTO 9999
  311.                   ENDIF
  312.                ELSE
  313.                   CONTRI=JPT.XMAT(IDIM1,IDIM2)*JPT.XMAT(IDIM3,IDIM4)
  314.                   IF (IDIM1.EQ.IDIM3) THEN
  315.                      CONTRI=CONTRI+IG.XMAT(IDIM2,IDIM4)
  316.                   ENDIF
  317.                   CONTRI=CONTRI-
  318.      $                 (JPTJT.XMAT(IDIM1,IDIM3)*IG.XMAT(IDIM2,IDIM4))
  319.                   CONTRI=CONTRI-
  320.      $                 (JPT.XMAT(IDIM3,IDIM2)*JPT.XMAT(IDIM1,IDIM4))
  321.                   CONTRI=CONTRI*XTS*SDETG
  322.                   IF (LAXSP.EQ.1) THEN
  323.                      CONTRI=CONTRI*DEUPI*XR
  324.                   ELSEIF (LAXSP.EQ.2) THEN
  325.                      CONTRI=CONTRI*QUATPI*XR*XR
  326.                   ENDIF
  327.                ENDIF
  328. *
  329. * Calcul d'une partie du jacobien
  330. *
  331.             ELSEIF (NOMLOI(1:3).EQ.'TSU') THEN
  332.                CALL CH2INT(NOMLOI(4:4),IDIM0,IMPR,IRET)
  333.                IF (IRET.NE.0) GOTO 9999
  334.                CALL CH2INT(NOMLOI(5:5),IDIM1,IMPR,IRET)
  335.                IF (IRET.NE.0) GOTO 9999
  336.                CALL CH2INT(NOMLOI(6:6),IDIM2,IMPR,IRET)
  337.                IF (IRET.NE.0) GOTO 9999
  338.                CALL CH2INT(NOMLOI(7:7),IDIM3,IMPR,IRET)
  339.                IF (IRET.NE.0) GOTO 9999
  340.                CALL CH2INT(NOMLOI(8:8),IDIM4,IMPR,IRET)
  341.                IF (IRET.NE.0) GOTO 9999
  342.                IF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)
  343.      $              .AND.(IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  344.                   WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  345.                   GOTO 9999
  346.                ELSEIF ((IDIM1.EQ.1).AND.(IDIM2.EQ.0)) THEN
  347.                   WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  348.                   GOTO 9999
  349.                ELSEIF ((IDIM3.EQ.1).AND.(IDIM4.EQ.0)) THEN
  350.                   WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  351.                   GOTO 9999
  352.                ELSE
  353.                   IF (IDIM0.EQ.1) THEN
  354.                      CONTRI=JPT.XMAT(IDIM1,IDIM2)*JPT.XMAT(IDIM3,IDIM4)
  355.                   ELSEIF (IDIM0.EQ.2) THEN
  356.                      IF (IDIM1.EQ.IDIM3) THEN
  357.                         CONTRI=IG.XMAT(IDIM2,IDIM4)
  358.                      ELSE
  359.                         CONTRI=0.D0
  360.                      ENDIF
  361.                   ELSEIF (IDIM0.EQ.3) THEN
  362.                      CONTRI=
  363.      $                    -(JPTJT.XMAT(IDIM1,IDIM3)*IG.XMAT(IDIM2,IDIM4)
  364.      $                    )
  365.                   ELSEIF (IDIM0.EQ.4) THEN
  366.                      CONTRI=-(JPT.XMAT(IDIM3,IDIM2)*JPT.XMAT(IDIM1,IDIM4
  367.      $                    ))
  368.                   ELSE
  369.                      WRITE(IOIMP,*) 'NOMLOI=',NOMLOI
  370.                      GOTO 9999
  371.                   ENDIF
  372.                   CONTRI=CONTRI*XTS*SDETG
  373.                   IF (LAXSP.EQ.1) THEN
  374.                      CONTRI=CONTRI*DEUPI*XR
  375.                   ELSEIF (LAXSP.EQ.2) THEN
  376.                      CONTRI=CONTRI*QUATPI*XR*XR
  377.                   ENDIF
  378.                ENDIF
  379. *!               WRITE(IOIMP,*) 'CONTRI=',CONTRI
  380.             ELSE
  381.                WRITE(IOIMP,*) 'Erreur grave'
  382.                GOTO 9999
  383.             ENDIF
  384.             FC.WELCHE(1,1,1,1,IPFC,ILFC)=
  385.      $           FC.WELCHE(1,1,1,1,IPFC,ILFC)+
  386.      $           CONTRI
  387.          ENDDO
  388.       ENDDO
  389.       SEGSUP,JPTJT
  390.       SEGSUP,JPT
  391.       SEGSUP,IG
  392.       SEGSUP,G
  393.       SEGSUP,JT
  394.       SEGSUP,JAC
  395. *
  396. * Normal termination
  397. *
  398.       IRET=0
  399.       RETURN
  400. *
  401. * Format handling
  402. *
  403. *
  404. * Error handling
  405. *
  406.  9999 CONTINUE
  407.       IRET=1
  408.       WRITE(IOIMP,*) 'An error was detected in subroutine ccgtsu'
  409.       RETURN
  410. *
  411. * End of subroutine CCGTSU
  412. *
  413.       END
  414.  
  415.  
  416.  
  417.  
  418.  
  419.  
  420.  
  421.  
  422.  

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