Télécharger la plaquette Cast3M


fr en

Télécharger epsln1.eso

Retour à la liste

Numérotation des lignes : 

epsln1

  1. C EPSLN1    SOURCE    OF166741  25/02/21    21:16:17     12166          
  2.  
  3.       SUBROUTINE EPSLN1(IPMODL,IPCHGR,IPCHCA,IPCHDE,IMIL)
  4.  
  5. *---------------------------------------------------------------------
  6. *
  7. *      CALCUL DE LA DEFORMATION LOGARITHMIQUE
  8. *                 (APPELE PAR EPSI)
  9. *
  10. *   ENTREES:
  11. *   --------
  12. *
  13. *     IPMODL   POINTEUR SUR UN MMODEL
  14. *     IPCHGR   POINTEUR SUR UN MCHAML DE GRADIENTS
  15. *     IPCHCA   POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  16. *              --> NON UTILISE POUR LE MOMENT
  17. *     IMIL     ENTIER CORRESPONDANT A GEOM (=0) OU A DEPL (=1)
  18. *              SI LE GRADIENT IPCHE1 EST CELUI DE LA TRANSFORMATION
  19. *              OU D'UN DEPLACEMENT.
  20. *
  21. *  SORTIES :
  22. *  ---------
  23. *
  24. *     IPCHDE   POINTEUR SUR UN MCHAML DE DEFORMATIONS
  25. *              = 0 EN CAS D'ERREUR
  26. *
  27. *---------------------------------------------------------------------
  28.  
  29.       IMPLICIT INTEGER(I-N)
  30.       IMPLICIT REAL*8(A-H,O-Z)
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC CCHAMP
  35. -INC SMCOORD
  36.  
  37. -INC SMCHAML
  38. -INC SMMODEL
  39. -INC SMINTE
  40.  
  41. -INC TMPTVAL
  42.  
  43.       SEGMENT NOTYPE
  44.         CHARACTER*16 TYPE(NBTYPE)
  45.       ENDSEGMENT
  46.  
  47. * Support des MCHAML (si non exprimes aux noeuds)
  48.       PARAMETER (INTYPS = 5)
  49.  
  50.       PARAMETER ( NINF=3 )
  51.       INTEGER INFOS(NINF)
  52.       CHARACTER*(NCONCH) CONM
  53.       logical lsupde,lsupgr
  54.  
  55.       DIMENSION F(9), EPS(6)
  56.  
  57.       IPCHDE = 0
  58.       IPCHS3 = 0
  59. *
  60. * Reduction des MCHAMLs sur le modele IPMODL
  61. *
  62.       kerre = 0
  63.  
  64.       IPCHE1 = IPCHGR
  65.       CALL REDUAF(IPCHE1,IPMODL,ipch,0,ir,kerre)
  66.       IF (ir.NE.1) CALL ERREUR(kerre)
  67.       IF (IERR.NE.0) RETURN
  68.       IPCHE1 = ipch
  69.  
  70.       IPCHE2 = IPCHCA
  71.       IF (IPCHE2.NE.0) THEN
  72.         CALL REDUAF(IPCHE2,IPMODL,ipch,0,ir,kerre)
  73.         IF (ir.NE.1) CALL ERREUR(kerre)
  74.         IF (IERR.NE.0) RETURN
  75.         IPCHE2 = ipch
  76.       ENDIF
  77. *
  78. * Verification sur le type de IPCHE1 (GRADIENT)
  79. *
  80.       MCHELM = IPCHE1
  81.       SEGACT,MCHELM
  82.       IF (TITCHE.NE.'GRADIENT') THEN
  83.         MOTERR(1:8)='GRADIENT'
  84.         CALL ERREUR(145)
  85.         GOTO 9990
  86.       ENDIF
  87. *
  88. * VERIFICATION DU LIEU SUPPORT DES MCHAMLS D'ENTREE
  89. *
  90.       CALL QUESUP(IPMODL,IPCHE1,INTYPS,0,ISUP1,ir)
  91.       IF (ISUP1.GT.1) GOTO 9990
  92.       IF (IPCHE2.NE.0) THEN
  93.         CALL QUESUP(IPMODL,IPCHE2,INTYPS,0,ISUP2,ir)
  94.         IF (ISUP2.GT.1) GOTO 9990
  95.       ENDIF
  96. *
  97. * ACTIVATION DU MODELE
  98. *
  99.       MMODEL=IPMODL
  100.       SEGACT,MMODEL
  101.       NSOUS = KMODEL(/1)
  102.  
  103. C ... Initialisation du MCHELM de DEFORMATIONS resultat ...
  104. *
  105. * DETERMINATION DU NOMBRE DE SOUS-ZONES DU MCHAML
  106. *
  107.       N1 = 0
  108.       DO ISOUS = 1, NSOUS
  109.         IMODEL = KMODEL(ISOUS)
  110.         SEGACT,IMODEL
  111.         MELE = NEFMOD
  112.         IF (MELE.NE.22.AND.FORMOD(1).NE.'CHARGEMENT') N1 = N1 + 1
  113.         IF (MELE.NE.259.AND.FORMOD(1).NE.'CHARGEMENT') N1 = N1 + 1
  114.       ENDDO
  115.  
  116.       L1 = 12
  117.       N3 = 6
  118.       SEGINI,MCHEL1
  119.       IPCHS3 = MCHEL1
  120. C
  121. C     le MCHAML resultat est de type DEFORMATIONS
  122. C
  123.       MCHEL1.IFOCHE=IFOUR
  124.       MCHEL1.TITCHE='DEFORMATIONS'
  125. *
  126. *  Petit segment utile (defini une fois pour toutes)
  127. *
  128.       NBTYPE = 1
  129.       SEGINI,NOTYPE
  130.       TYPE(1)='REAL*8'
  131.       MOTYPG = NOTYPE
  132.  
  133. *     ===================================
  134. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  135. *     ===================================
  136.       ISOUSS = 0
  137. *
  138.       DO 10 ISOUS = 1, NSOUS
  139. *
  140. *    ... INITIALISATIONS ...
  141. *
  142.         NGRA  =0
  143.         IVAGRA=0
  144.         MOGRAD=0
  145.         lsupgr = .false.
  146.         NDEF=0
  147.         IVAEPS=0
  148.         MOEPSI=0
  149.         lsupde = .false.
  150.         IPMINT = 0
  151. *
  152. *  ... TRAITEMENT DU SOUS-MODELE ...
  153. *
  154.         IMODEL=KMODEL(ISOUS)
  155. c*        SEGACT,IMODEL
  156. *
  157.         MELE  = NEFMOD
  158.         IPMAIL= IMAMOD
  159.         CONM  = CONMOD
  160.         IF (MELE.EQ.22.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199
  161.         IF (MELE.EQ.259.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199
  162. *
  163.         ISOUSS = ISOUSS + 1
  164. *
  165. *    ... INFOS GENERALES ...
  166. *
  167. C    ... COQUE INTEGREE OU PAS ? ...
  168.         NPINT=INFMOD(1)
  169.         IF (NPINT.NE.0) THEN
  170.           CALL ERREUR(615)
  171.           GOTO 199
  172.         ENDIF
  173. *
  174. *    ... INFORMATION SUR L'ELEMENT FINI ...
  175. *
  176.         MFR   =INFELE(13)
  177. *        IPMINT =INFELE(11)
  178.         IPMINT=INFMOD(2+INTYPS)
  179.         IF (IPMINT.NE.0) THEN
  180.           MINTE = IPMINT
  181.           SEGACT,MINTE
  182.         ENDIF
  183.         IPPORE = 0
  184. *
  185. *    TEST SUR MFR : MASSIF UNIQUEMENT POUR L'INSTANT
  186. *
  187.         IF (MFR.NE.1) THEN
  188.           CALL ERREUR(26)
  189.           GOTO 199
  190.         ENDIF
  191. *
  192. *  ... Verification de compatibilité des MCHAML du point de vue des
  193. *      tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ...
  194. *
  195.        CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,iret)
  196.        IF (iret.EQ.0) GOTO 199
  197. *
  198. *    ... RECHERCHE DES NOMS de COMPOSANTES ...
  199. *
  200.         IF (lnomid(3).NE.0) THEN
  201.           mograd = lnomid(3)
  202.         ELSE
  203.           lsupgr = .true.
  204.           CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,nfac)
  205.         ENDIF
  206.         nomid=MOGRAD
  207.         SEGACT,nomid
  208.         NGRA=lesobl(/2)
  209. C*        nfac=lesfac(/2)
  210. *
  211.         LADIM=0
  212.         IF (NGRA.EQ.4) LADIM=2
  213.         IF (NGRA.EQ.9) LADIM=3
  214.         IF (LADIM.EQ.0) THEN
  215.           CALL ERREUR(26)
  216.           GOTO 199
  217.         ENDIF
  218.  
  219.         IF (lnomid(5).NE.0) THEN
  220.           MOEPSI = lnomid(5)
  221.         ELSE
  222.           lsupde = .true.
  223.           CALL IDDEFO(IMODEL,IFOUR,MOEPSI,NDEF,nfac)
  224.         ENDIF
  225.         nomid=MOEPSI
  226.         SEGACT,nomid
  227.         NDEF = lesobl(/2)
  228. C*        nfac=lesfac(/2)
  229. *
  230. *    ... VERIFICATION DE LEUR PRESENCE ...
  231. *
  232.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRAD,MOTYPG,1,INFOS,3,IVAGRA)
  233.         IF (IERR.NE.0) GOTO 199
  234. *
  235. * Changement de support du gradient (NOEUDS vers INTYPS)
  236.         IF (ISUP1.EQ.1) THEN
  237.           CALL VALCHE(IVAGRA,NGRA,IPMINT,IPPORE,MOGRAD,MELE)
  238.           IF (IERR.NE.0) THEN
  239.             ISUP1 = 0
  240.             GOTO 199
  241.           ENDIF
  242.         ENDIF
  243. *
  244. *    ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ...
  245. *
  246.         N1PTEL=0
  247.         N1EL  =0
  248.         MPTVAL=IVAGRA
  249.         DO 110 ICOMP=1,NGRA
  250.           MELVAL=IVAL(ICOMP)
  251.           N1PTEL=MAX(N1PTEL,VELCHE(/1))
  252.           N1EL  =MAX(N1EL  ,VELCHE(/2))
  253.  110    CONTINUE
  254.         N2PTEL=0
  255.         N2EL=0
  256. *
  257. *    ... Les attributs de chaque sous-zone ...
  258. *
  259.         MCHEL1.INFCHE(ISOUSS,1)=0
  260.         MCHEL1.INFCHE(ISOUSS,2)=0
  261.         MCHEL1.INFCHE(ISOUSS,3)=NIFOUR
  262.         MCHEL1.INFCHE(ISOUSS,4)=IPMINT
  263.         MCHEL1.INFCHE(ISOUSS,5)=0
  264.         MCHEL1.INFCHE(ISOUSS,6)=INTYPS
  265.         MCHEL1.IMACHE(ISOUSS)=IPMAIL
  266.         MCHEL1.CONCHE(ISOUSS)=CONMOD
  267. *
  268. *    ... Création et stockage des MCHAML ...
  269. *
  270.         N2 = NDEF
  271.         SEGINI,MCHAM1
  272.         MCHEL1.ICHAML(ISOUSS)=MCHAM1
  273. *
  274. C    ... et des MELVAL de la zone élémentaire ...
  275. C
  276.         NSR=1
  277.         NCOSOR=NDEF
  278.         SEGINI,MPTVAL
  279.         IVAEPS=MPTVAL
  280.         NOMID=MOEPSI
  281.         DO 111 ICOMP=1,NDEF
  282.           MCHAM1.TYPCHE(ICOMP)='REAL*8'
  283.           MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  284.           SEGINI,MELVAL
  285.           MCHAM1.IELVAL(ICOMP)=MELVAL
  286.           IVAL(ICOMP)=MELVAL
  287.  111    CONTINUE
  288. *
  289. **********************************************************************
  290. *                                                                    *
  291. *               BRANCHEMENT SUIVANT LA DIMENSION                     *
  292. *                                                                    *
  293. **********************************************************************
  294. *
  295. *   BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS
  296. *
  297.         DO IB=1,N1EL
  298. *
  299.           DO IGAU=1,N1PTEL
  300. *
  301. *       ... Recherche des composantes du gradient
  302. *
  303.             MPTVAL=IVAGRA
  304.             DO 35 ICOMP = 1, NGRA
  305.                MELVAL=IVAL(ICOMP)
  306.                IGMN=MIN(IGAU,VELCHE(/1))
  307.                IBMN=MIN(IB  ,VELCHE(/2))
  308.                F(ICOMP)=VELCHE(IGMN,IBMN)
  309.    35       CONTINUE
  310. *
  311. *       ... Ajout de 1 aux termes diagonaux si mot DEPL lu
  312. *
  313.             IF (IMIL.EQ.1) THEN
  314.               IF (LADIM.EQ.3) THEN
  315.                 F(1)=F(1)+1.
  316.                 F(5)=F(5)+1.
  317.                 F(9)=F(9)+1.
  318.               ELSE IF (LADIM.EQ.2) THEN
  319.                 F(1)=F(1)+1.
  320.                 F(4)=F(4)+1.
  321.               ENDIF
  322.             ENDIF
  323. *
  324. *       ... Calcul des composantes de EPS ...
  325. *
  326.             CALL EPSLN2(F,EPS,LADIM)
  327.             IF (IERR.NE.0) GOTO 199
  328. *
  329. *       ... et leur stockage ...
  330. *
  331.             MPTVAL=IVAEPS
  332.             DO 36 ICOMP=1,NDEF
  333.               MELVAL=IVAL(ICOMP)
  334.               VELCHE(IGAU,IB)=EPS(ICOMP)
  335.  36         CONTINUE
  336.  
  337.           ENDDO
  338.  
  339.         ENDDO
  340. *
  341. *    ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  342. *
  343.  199    CONTINUE
  344.  
  345.         IF (ISUP1.EQ.1) THEN
  346.           CALL DTMVAL(IVAGRA,3)
  347.         ELSE
  348.           CALL DTMVAL(IVAGRA,1)
  349.         ENDIF
  350.  
  351.         IF (IERR.EQ.0) THEN
  352.           MPTVAL=IVAEPS
  353.           DO ICOMP = 1, IVAL(/1)
  354.             MELVAL = IVAL(ICOMP)
  355.             CALL COMRED(MELVAL)
  356.             IVAL(ICOMP)=MELVAL
  357.           ENDDO
  358.           CALL DTMVAL(IVAEPS,1)
  359.           SEGDES,MCHAM1
  360.         ELSE
  361.           CALL DTMVAL(IVAEPS,3)
  362.           SEGSUP,MCHAM1
  363.         ENDIF
  364.  
  365.         IF (MOGRAD.NE.0) THEN
  366.           nomid=MOGRAD
  367.           SEGDES,nomid
  368.           IF (lsupgr) SEGSUP,nomid
  369.         ENDIF
  370.  
  371.         IF (MOEPSI.NE.0) THEN
  372.           nomid=MOEPSI
  373.           SEGDES,nomid
  374.           IF (lsupde) SEGSUP,nomid
  375.         ENDIF
  376.  
  377.         SEGDES,IMODEL
  378. *
  379.         IF (IERR.NE.0) GOTO 9991
  380. *
  381.  10   CONTINUE
  382. C     ===========================================
  383. C ... FIN DE LA BOUCLE SUR LES ZONES ELEMENTAIRES ...
  384. C     ===========================================
  385.  
  386. *
  387.  9991 CONTINUE
  388.       SEGDES,MMODEL
  389.       notype = MOTYPG
  390.       SEGSUP,notype
  391.       IF (IERR.NE.0) THEN
  392.         SEGSUP,MCHEL1
  393.         IPCHDE = 0
  394.       ELSE
  395.         SEGDES,MCHEL1
  396.         IPCHDE = IPCHS3
  397.       ENDIF
  398.  9990 CONTINUE
  399.       SEGDES,MCHELM
  400.  
  401.       RETURN
  402.       END
  403.  
  404.  
  405.  

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