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    CB215821  24/04/12    21:15:48     11897          
  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.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC CCHAMP
  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. C
  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. C
  172.         IF (INFMOD(/1).NE.0) THEN
  173.           NPINT=INFMOD(1)
  174.         ELSE
  175.           NPINT=0
  176.         ENDIF
  177.         IF (NPINT.NE.0) THEN
  178.           CALL ERREUR(615)
  179.           GOTO 199
  180.         ENDIF
  181. *
  182. *    ... INFORMATION SUR L'ELEMENT FINI ...
  183. *
  184.         MFR   =INFELE(13)
  185. *        IPMINT =INFELE(11)
  186.         IPMINT=INFMOD(2+INTYPS)
  187.         IF (IPMINT.NE.0) THEN
  188.           MINTE = IPMINT
  189.           SEGACT,MINTE
  190.         ENDIF
  191.         IPPORE = 0
  192. *
  193. *    TEST SUR MFR : MASSIF UNIQUEMENT POUR L'INSTANT
  194. *
  195.         IF (MFR.NE.1) THEN
  196.           CALL ERREUR(26)
  197.           GOTO 199
  198.         ENDIF
  199. *
  200. *  ... Verification de compatibilité des MCHAML du point de vue des
  201. *      tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ...
  202. *
  203.        CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,iret)
  204.        IF (iret.EQ.0) GOTO 199
  205. *
  206. *    ... RECHERCHE DES NOMS de COMPOSANTES ...
  207. *
  208.         IF (lnomid(3).NE.0) THEN
  209.           mograd = lnomid(3)
  210.         ELSE
  211.           lsupgr = .true.
  212.           CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,nfac)
  213.         ENDIF
  214.         nomid=MOGRAD
  215.         SEGACT,nomid
  216.         NGRA=lesobl(/2)
  217. C*        nfac=lesfac(/2)
  218. *
  219.         LADIM=0
  220.         IF (NGRA.EQ.4) LADIM=2
  221.         IF (NGRA.EQ.9) LADIM=3
  222.         IF (LADIM.EQ.0) THEN
  223.           CALL ERREUR(26)
  224.           GOTO 199
  225.         ENDIF
  226.  
  227.         IF (lnomid(5).NE.0) THEN
  228.           MOEPSI = lnomid(5)
  229.         ELSE
  230.           lsupde = .true.
  231.           CALL IDDEFO(IMODEL,IFOUR,MOEPSI,NDEF,nfac)
  232.         ENDIF
  233.         nomid=MOEPSI
  234.         SEGACT,nomid
  235.         NDEF = lesobl(/2)
  236. C*        nfac=lesfac(/2)
  237. *
  238. *    ... VERIFICATION DE LEUR PRESENCE ...
  239. *
  240.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRAD,MOTYPG,1,INFOS,3,IVAGRA)
  241.         IF (IERR.NE.0) GOTO 199
  242. *
  243. * Changement de support du gradient (NOEUDS vers INTYPS)
  244.         IF (ISUP1.EQ.1) THEN
  245.           CALL VALCHE(IVAGRA,NGRA,IPMINT,IPPORE,MOGRAD,MELE)
  246.           IF (IERR.NE.0) THEN
  247.             ISUP1 = 0
  248.             GOTO 199
  249.           ENDIF
  250.         ENDIF
  251. *
  252. *    ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ...
  253. *
  254.         N1PTEL=0
  255.         N1EL  =0
  256.         MPTVAL=IVAGRA
  257.         DO 110 ICOMP=1,NGRA
  258.           MELVAL=IVAL(ICOMP)
  259.           N1PTEL=MAX(N1PTEL,VELCHE(/1))
  260.           N1EL  =MAX(N1EL  ,VELCHE(/2))
  261.  110    CONTINUE
  262.         N2PTEL=0
  263.         N2EL=0
  264. *
  265. *    ... Les attributs de chaque sous-zone ...
  266. *
  267.         MCHEL1.INFCHE(ISOUSS,1)=0
  268.         MCHEL1.INFCHE(ISOUSS,2)=0
  269.         MCHEL1.INFCHE(ISOUSS,3)=NIFOUR
  270.         MCHEL1.INFCHE(ISOUSS,4)=IPMINT
  271.         MCHEL1.INFCHE(ISOUSS,5)=0
  272.         MCHEL1.INFCHE(ISOUSS,6)=INTYPS
  273.         MCHEL1.IMACHE(ISOUSS)=IPMAIL
  274.         MCHEL1.CONCHE(ISOUSS)=CONMOD
  275. *
  276. *    ... Création et stockage des MCHAML ...
  277. *
  278.         N2 = NDEF
  279.         SEGINI,MCHAM1
  280.         MCHEL1.ICHAML(ISOUSS)=MCHAM1
  281. *
  282. C    ... et des MELVAL de la zone élémentaire ...
  283. C
  284.         NS=1
  285.         NCOSOU=NDEF
  286.         SEGINI,MPTVAL
  287.         IVAEPS=MPTVAL
  288.         NOMID=MOEPSI
  289.         DO 111 ICOMP=1,NDEF
  290.           MCHAM1.TYPCHE(ICOMP)='REAL*8'
  291.           MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  292.           SEGINI,MELVAL
  293.           MCHAM1.IELVAL(ICOMP)=MELVAL
  294.           IVAL(ICOMP)=MELVAL
  295.  111    CONTINUE
  296. *
  297. **********************************************************************
  298. *                                                                    *
  299. *               BRANCHEMENT SUIVANT LA DIMENSION                     *
  300. *                                                                    *
  301. **********************************************************************
  302. *
  303. *   BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS
  304. *
  305.         DO 31 IB=1,N1EL
  306. *
  307.           DO 31 IGAU=1,N1PTEL
  308. *
  309. *       ... Recherche des composantes du gradient
  310. *
  311.             MPTVAL=IVAGRA
  312.             DO 35 ICOMP = 1, NGRA
  313.                MELVAL=IVAL(ICOMP)
  314.                IGMN=MIN(IGAU,VELCHE(/1))
  315.                IBMN=MIN(IB  ,VELCHE(/2))
  316.                F(ICOMP)=VELCHE(IGMN,IBMN)
  317.    35       CONTINUE
  318. *
  319. *       ... Ajout de 1 aux termes diagonaux si mot DEPL lu
  320. *
  321.             IF (IMIL.EQ.1) THEN
  322.               IF (LADIM.EQ.3) THEN
  323.                 F(1)=F(1)+1.
  324.                 F(5)=F(5)+1.
  325.                 F(9)=F(9)+1.
  326.               ELSE IF (LADIM.EQ.2) THEN
  327.                 F(1)=F(1)+1.
  328.                 F(4)=F(4)+1.
  329.               ENDIF
  330.             ENDIF
  331. *
  332. *       ... Calcul des composantes de EPS ...
  333. *
  334.             CALL EPSLN2(F,EPS,LADIM)
  335.             IF (IERR.NE.0) GOTO 199
  336. *
  337. *       ... et leur stockage ...
  338. *
  339.             MPTVAL=IVAEPS
  340.             DO 36 ICOMP=1,NDEF
  341.               MELVAL=IVAL(ICOMP)
  342.               VELCHE(IGAU,IB)=EPS(ICOMP)
  343.  36         CONTINUE
  344. *
  345.  31     CONTINUE
  346. *
  347. *    ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  348. *
  349.  199    CONTINUE
  350. *
  351.         IF (IPMINT.NE.0) THEN
  352.           MINTE = IPMINT
  353.           SEGDES,MINTE
  354.         ENDIF
  355. *
  356.         IF (ISUP1.EQ.1) THEN
  357.           CALL DTMVAL(IVAGRA,3)
  358.         ELSE
  359.           CALL DTMVAL(IVAGRA,1)
  360.         ENDIF
  361. *
  362.         IF (IERR.EQ.0) THEN
  363.           MPTVAL=IVAEPS
  364.           DO ICOMP = 1, IVAL(/1)
  365.             MELVAL = IVAL(ICOMP)
  366.             CALL COMRED(MELVAL)
  367.             IVAL(ICOMP)=MELVAL
  368.           ENDDO
  369.           CALL DTMVAL(IVAEPS,1)
  370.           SEGDES,MCHAM1
  371.         ELSE
  372.           CALL DTMVAL(IVAEPS,3)
  373.           SEGSUP,MCHAM1
  374.         ENDIF
  375. *
  376.         IF (MOGRAD.NE.0) THEN
  377.           nomid=MOGRAD
  378.           SEGDES,nomid
  379.           IF (lsupgr) SEGSUP,nomid
  380.         ENDIF
  381. *
  382.         IF (MOEPSI.NE.0) THEN
  383.           nomid=MOEPSI
  384.           SEGDES,nomid
  385.           IF (lsupde) SEGSUP,nomid
  386.         ENDIF
  387. *
  388.         SEGDES,IMODEL
  389. *
  390.         IF (IERR.NE.0) GOTO 9991
  391. *
  392.  10   CONTINUE
  393. C     ===========================================
  394. C ... FIN DE LA BOUCLE SUR LES ZONES ELEMENTAIRES ...
  395. C     ===========================================
  396.  
  397. *
  398.  9991 CONTINUE
  399.       SEGDES,MMODEL
  400.       notype = MOTYPG
  401.       SEGSUP,notype
  402.       IF (IERR.NE.0) THEN
  403.         SEGSUP,MCHEL1
  404.         IPCHDE = 0
  405.       ELSE
  406.         SEGDES,MCHEL1
  407.         IPCHDE = IPCHS3
  408.       ENDIF
  409.  9990 CONTINUE
  410.       SEGDES,MCHELM
  411.  
  412.       RETURN
  413.       END
  414.  
  415.  
  416.  
  417.  
  418.  
  419.  
  420.  
  421.  
  422.  
  423.  

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