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

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