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

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