Télécharger la plaquette Cast3M


fr en

Télécharger piocap.eso

Retour à la liste

Numérotation des lignes : 

piocap

  1. C PIOCAP    SOURCE    MB234859  25/09/08    21:15:57     12358          
  2.       SUBROUTINE PIOCAP(IPMODL,IPCHE1,IPCHP1,IPCHP0,ICHAX1,
  3.      &                  IM,IDERI,IPCHE2,IRET)
  4. C_______________________________________________________________________
  5. C
  6. C
  7. C    Entr{es:
  8. C    ________
  9. C
  10. C           IPMODL Pointeur sur un MMODEL
  11. C           IPCHE1 Pointeur sur un MCHAML de contraintes de KIRCHHOFF
  12. C                                      OU DE DEFORMATIONS
  13. C                                      OU DE MATRICES DE HOOKE
  14. C           IPCHP1 Pointeur sur le CHAMPOINT d{placements entre
  15. C                  configuration de depart et arrivee
  16. C           IM     Flag ,= 0 KIRCHHOFF------> CAUCHY
  17. C                        = 1 CAUCHY-------> KIRCHHOFF
  18. c           IDERI = 4 si derivee de jauman (on fait RTENS RART avec R
  19. c                                           matrice de rotation)
  20. c           IDERI = 5 si derivee utilisateur (on ne fait rien ici ?)
  21. C    Sorties:
  22. C    ________
  23. C
  24. C           IPCHE2 Pointeur sur un MCHAML de CONTRAINTES
  25. C                                      OU DE DEFORMATIONS
  26. C                                      OU DE MATRICES DE HOOKE
  27. C           IRET   1 ou 0 suivant succes ou pas
  28. C
  29. C_______________________________________________________________________
  30. C
  31.       IMPLICIT INTEGER(I-N)
  32.       IMPLICIT REAL*8(A-H,O-Z)
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC CCHAMP
  37.  
  38. -INC SMCHAML
  39. -INC SMCHPOI
  40. -INC SMELEME
  41. -INC SMCOORD
  42. -INC SMMODEL
  43. -INC SMINTE
  44. -INC SMLREEL
  45.  
  46. -INC TMPTVAL
  47.  
  48.       SEGMENT MWRK1
  49.        REAL*8 XE(3,NBNN) ,XE1(3,NBNN) ,XE2(3,NBNN)
  50.       ENDSEGMENT
  51. *
  52.       SEGMENT MWRK2
  53.        REAL*8 SHPWRK(6,NBNN)
  54.       ENDSEGMENT
  55. *
  56.       SEGMENT MWRK3
  57.        REAL*8 STRESS(NBPTEL,NSTRS),STRES1(NBPTEL,NSTRS)
  58.       ENDSEGMENT
  59. *
  60.       SEGMENT MWRK4
  61.        REAL*8 XEL(3,3), BPSS (3,3), XDDL(18), XDDLOC(18)
  62.       ENDSEGMENT
  63. *
  64.       SEGMENT MWRK5
  65.         REAL*8 BGR(NGRA,LRE),BB(2,NGRA),gradi(ngra),R(ngra),u(ngra)
  66.         REAL*8 TENS(9),tentra(9),xddls2(lre)
  67.       ENDSEGMENT
  68. *
  69.       SEGMENT MWRK6
  70.        INTEGER ITRES1(NBPTEL)
  71.        REAL*8 PRODDI(NBPTEL,LHOO2),PRODDO(NBPTEL,LHOO2)
  72.        REAL*8 DDHOOK(LHOOK,LHOOK),DDHOMU(LHOOK,LHOOK)
  73.        REAL*8 VEC(LHOOK),VEC2(LHOOK)
  74.       ENDSEGMENT
  75. *
  76.       SEGMENT NOTYPE
  77.         CHARACTER*16 TYPE(NBTYPE)
  78.       ENDSEGMENT
  79. *
  80. *as xfem 2010_01_13
  81.       SEGMENT MRACC
  82.         INTEGER TLREEL(NBNN)
  83.       ENDSEGMENT
  84.  
  85.       SEGMENT TABA
  86.         REAL*8 TABA1(IDIM,NBNN),TABA2(IDIM,NBNN)
  87.       ENDSEGMENT
  88. *fin as xfem 2010_01_13
  89.  
  90.       CHARACTER*(NCONCH) CONM
  91.       CHARACTER*8 CMATE
  92.       PARAMETER ( NINF=3 )
  93.       INTEGER INFOS(NINF)
  94. *as xfem 2010_01_22
  95.       DIMENSION UDPGE(3)
  96.       LOGICAL ldpge,lsupdp,lsupno,lsupdp0
  97.       character*16 titchl
  98. *
  99.       segact mcoord
  100.       NHRM=NIFOUR
  101.       IRET=0
  102.       IMESS=0
  103. *
  104. *     Verification du lieu support du MCHAML
  105. *
  106.       mchelm=ipche1
  107.       segact mchelm
  108.       call reduaf(ipche1,ipmodl,ipch,0,iretou,kerr)
  109.       mchelm=ipch
  110.       segact mchelm
  111.       if (iretou.ne.1) call erreur(kerr)
  112.       if (ierr.ne.0) return
  113.       ipche1=ipch
  114.       CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP,IRET2)
  115.       IF (ISUP.GT.1) RETURN
  116. c
  117. *as xfem 2010_01_13
  118. *   Calcul du niveau d'enrichissement du modèle :
  119.       IF (ichax1.ne.0) then
  120.          ipchp2=0
  121.          MCHAM1=ICHAX1
  122.          nbenr1=MCHAM1.IELVAL(/1)
  123.          if (nbenr1.gt.1) then
  124.            write(ioimp,*) 'XFEM : on ne sait pas traiter les grandes ',
  125.      &              'transformations avec un niveau denrichissement >1'
  126.            CALL ERREUR(21)
  127.            return
  128.          endif
  129. *   Calcul des déplacements vrais :
  130.         call XPOST1(IPCHP1,IPMODL,IPCHP2)
  131.       ENDIF
  132. *fin as xfem 2010_01_13
  133. *
  134. *   CONTRAINTES (KCAS=1) OU DEFORMATIONS (KCAS=2)
  135. *                        OU MATRICES DE HOOKE (KCAS=3)
  136. *
  137.       MCHELM=IPCHE1
  138.       segact mchelm
  139.       TITCHL=TITCHE
  140.       IF (TITCHL.EQ.'CONTRAINTES') THEN
  141.          KCAS=1
  142.       ELSE IF(TITCHE.EQ.'DEFORMATIONS') THEN
  143.          KCAS=2
  144.       ELSE IF(TITCHE.EQ.'MATRICE DE HOOKE') THEN
  145.          KCAS=3
  146.       ELSE
  147.          MOTERR(1:16)  ='CONTRAINTES'
  148.          MOTERR(17:32) ='DEFORMATIONS'
  149.          MOTERR(33:48)='MATRICE DE HOOKE'
  150.          CALL ERREUR(1140)
  151.          RETURN
  152.       ENDIF
  153. C
  154. C     ON CONVERTIT LE CHAMP POINT EN CHAMP PAR ELEMENT
  155. C____________________________________________________________________
  156. C
  157.       CALL  CHAME1(0,IPMODL,IPCHP1,' ',IPCHE3,1)
  158. *as xfem 2010_01_13
  159.       if(ichax1.ne.0) then
  160. * IPCHP1 : Deplacement enrichi : config initiale -> config finale
  161. * Deplacement enrichi : config de reference -> config finale
  162.         CALL CHAME1(0,IPMODL,IPCHP0,' ',IPCHE0,1)
  163. * Deplacement vrai : config initiale -> config finale
  164.         CALL CHAME1(0,IPMODL,IPCHP2,' ',IPCHE4,1)
  165.       endif
  166. *fin as xfem 2010_01_13
  167. C
  168. C     ACTIVATION DU MODELE
  169. C
  170.       MMODEL=IPMODL
  171.       NSOUS=KMODEL(/1)
  172.       N1=NSOUS
  173. C
  174. C     ON NE TIENT PAS COMPTE D'UN EVENTUEL MODELE CHARGEMENT
  175. C
  176.       DO III = 1,NSOUS
  177.         IMODEL = KMODEL(III)
  178.         IF (FORMOD(1).EQ.'CHARGEMENT') N1=N1-1
  179.       END DO
  180. C
  181. C     CREATION DU MCHELM
  182. C
  183.       IF (KCAS.EQ.1) L1=11
  184.       IF (KCAS.EQ.2) L1=12
  185.       IF (KCAS.EQ.3) L1=16
  186.       N3=6
  187.       SEGINI MCHELM
  188.       IF(KCAS.EQ.1) TITCHE='CONTRAINTES'
  189.       IF(KCAS.EQ.2) TITCHE='DEFORMATIONS'
  190.       IF(KCAS.EQ.3) TITCHE='MATRICE DE HOOKE'
  191.       IFOCHE=IFOUR
  192.       IPCHE2=MCHELM
  193. C____________________________________________________________________
  194. C
  195. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  196. C____________________________________________________________________
  197. C
  198.       ISOUS=0
  199.       DO 500 ISOU=1,NSOUS
  200. C
  201. C    INITIALISATION
  202. C
  203.       MWRK1=0
  204.       MWRK2=0
  205.       MWRK3=0
  206.       MWRK4=0
  207.       IVADEP=0
  208.       NDEP=0
  209.       IVAST1=0
  210.       IVASTR=0
  211.       NSTR=0
  212.       MODEPV=0
  213.       MODEPL=0
  214.       MOSTRS=0
  215. C
  216. C     ON RECUPERE L INFORMATION GENERALE
  217. C
  218.       IMODEL=KMODEL(ISOU)
  219.       IF (FORMOD(1).EQ.'CHARGEMENT') GOTO 500
  220.       IPMAIL = imodel.IMAMOD
  221.       CONM   = imodel.CONMOD
  222.       IIPDPG = imodel.IPDPGE
  223.       IIPDPG = IPTPOI(IIPDPG)
  224. C
  225. C     TRAITEMENT DU MODELE
  226. C
  227. C On n'utilise pas PICA avec un des modeles interdits (OTTOSEN, UO2) ou
  228. C le modele utilisateur UMAT (cas contrainte deja de Cauchy)
  229. * septembre 2019: on remet en fonction pica avec ottosen et uo2
  230. C Cette partie de l'operateur est a ameliorer (juste copie du CHAMP !!!)
  231.         IPICA = 1
  232. **      IF ( INATUU.EQ.108 .OR. INATUU.EQ.42 .OR. INATUU.EQ.-1 ) THEN
  233.         IF ( INATUU.EQ.-1 ) THEN
  234.           IPICA = 0
  235.         ENDIF
  236.  
  237.       MELE=NEFMOD
  238.       MELEME=IMAMOD
  239.       CMATE=CMATEE
  240. c       ideri=ideriv
  241. cbp,2020-12-10 : ideriv n'est plus utilise -> IDERI en argument
  242.  
  243. C____________________________________________________________________
  244. C
  245. C     INFORMATION SUR L'ELEMENT FINI
  246. C____________________________________________________________________
  247. C
  248.       MFR  =INFELE(13)
  249.       IPORE=INFELE(8)
  250.       NBG  =INFELE(6)
  251.       NBGS =INFELE(4)
  252.       NSTRS=INFELE(16)
  253.       LRE  =INFELE(9)
  254.       LW   =INFELE(7)
  255.       LHOOK=INFELE(10)
  256.       LHOO2=LHOOK*LHOOK
  257.       NDDL =INFELE(15)
  258.       if (infmod(/1).lt.7) goto 500
  259.       minte=infmod(7)
  260.       if (minte.eq.0) goto 500
  261.       IPMINT=MINTE
  262.       MINTE1=INFMOD(3)
  263.       ISOUS=ISOUS+1
  264.       IMACHE(ISOUS)=IPMAIL
  265.       CONCHE(ISOUS)=CONMOD
  266. *      SEGSUP INFO
  267. C
  268. C     CREATION DU TABLEAU INFOS
  269. C
  270.       INFOS(1)=0
  271.       INFOS(2)=0
  272.       INFOS(3)=NIFOUR
  273. C
  274.       INFCHE(ISOUS,1)=0
  275.       INFCHE(ISOUS,2)=0
  276.       INFCHE(ISOUS,3)=NHRM
  277.       INFCHE(ISOUS,4)=MINTE
  278.       INFCHE(ISOUS,5)=0
  279.       INFCHE(ISOUS,6)=5
  280. C
  281. C     INITIALISATION DE MINTE
  282. C
  283.       NBPGAU=POIGAU(/1)
  284. C
  285. C  Cas des modes de calculs en DEFORMATIONS GENERALISEES
  286.       CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  287. C
  288. C     ACTIVATION DU MELEME
  289. C
  290.       NBNN  =NUM(/1)
  291.       NBELEM=NUM(/2)
  292. *as xfem 2010_01_13
  293.        if (MFR.eq.63) then
  294.          NBSH=INFELE(8)
  295.        else
  296.          NBSH=NBNN
  297.        endif
  298. *fin as xfem 2010_01_13
  299.       IPPORE=0
  300.       IF(MFR.EQ.33) IPPORE=NBNN
  301. C____________________________________________________________________
  302. C
  303. C     RECHERCHE DES NOMS DE COMPOSANTES
  304. C____________________________________________________________________
  305. C
  306.       lsupno=.false.
  307.       IF(KCAS.EQ.1) THEN
  308.         if(lnomid(4).ne.0) then
  309.           nomid=lnomid(4)
  310.           mostrs=nomid
  311.           nstr=lesobl(/2)
  312.           nfac=lesfac(/2)
  313.         else
  314.          lsupno=.true.
  315.          CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  316.          endif
  317.       ENDIF
  318.       IF(KCAS.EQ.2) THEN
  319.         if(lnomid(5).ne.0) then
  320.          nomid=lnomid(5)
  321.          nstr=lesobl(/2)
  322.          mostrs=nomid
  323.          nfac=lesfac(/2)
  324.         else
  325.          lsupno=.true.
  326.          CALL IDDEFO(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  327.         endif
  328.       ENDIF
  329. *
  330.       IF(KCAS.EQ.3) THEN
  331.  
  332. *         CAS PARTICULIER DST,JOT3,JOI4 ORTHOTROPES
  333.           IF((MELE.EQ.93.OR.MELE.EQ.87.OR.MELE.EQ.88).AND.
  334.      &        CMATE.NE.'ISOTROPE')THEN
  335.             NBROBL=3
  336.             NBRFAC=0
  337.             SEGINI NOMID
  338.             LESOBL(1)='MAHO'
  339.             LESOBL(2)='V1X '
  340.             LESOBL(3)='V1Y '
  341.             NBTYPE=3
  342.             SEGINI NOTYPE
  343.             TYPE(1)='POINTEURLISTREEL'
  344.             TYPE(2)='REAL*8'
  345.             TYPE(3)='REAL*8'
  346.           ELSE
  347.             NBROBL   =1
  348.             NBRFAC   =0
  349.             SEGINI NOMID
  350.             LESOBL(1)='MAHO'
  351.             NBTYPE   =1
  352.             SEGINI NOTYPE
  353.             TYPE(1)  ='POINTEURLISTREEL'
  354.           ENDIF
  355.           NHOK = NBROBL
  356.           NFAC = NBRFAC
  357.           MOHOOK = NOMID
  358.           NOTYHO = NOTYPE
  359.       ENDIF
  360. C
  361.       if(lnomid(1).ne.0) then
  362.          nomid=lnomid(1)
  363.          modepl=nomid
  364.          ndep=lesobl(/2)
  365.          nfac=lesfac(/2)
  366.          lsupdp=.false.
  367.       else
  368.          lsupdp=.true.
  369.        CALL IDPRIM(IMODEL,0,MODEPL,NDEP,NFAC)
  370.       endif
  371.  
  372. c     cas de la derivee de JAUMANN : repere corotationnel -> global
  373.       if (ideri.eq.4) then
  374.         IF (LNOMID(3).NE.0) then
  375.           MOGRAD=LNOMID(3)
  376.           NOMID=MOGRAD
  377.           NGRA=LESOBL(/2)
  378.         ELSE
  379.           CALL IDGRAD(IMODEL,IFOUR,MOGRAD,NGRA,NFAC)
  380.         ENDIF
  381.         LADIM=0
  382.         IF (NGRA.EQ.4) LADIM=2
  383.         IF (NGRA.EQ.9) LADIM=3
  384.         IF (LADIM.EQ.0) THEN
  385.           CALL ERREUR(26)
  386.           RETURN
  387.         ENDIF
  388.       endif
  389.  
  390. *as xfem 2010_01_13
  391. * On récupère les noms des composantes du cas massif, pour les depl. vrais
  392.       lsupdp0=.false.
  393.       IF (ichax1.ne.0) then
  394.          MFRTMP=1
  395.          call idprim(IMODEL,MFRTMP,MODEPV,NDEPV,NFACV)
  396. * as 2010_01_22
  397.          lsupdp0=.true.
  398.       ENDIF
  399. *fin as xfem 2010_01_13
  400.  
  401. C  Recherche des DDL du noeud support des def. planes generalisees
  402.       IF (ldpge) THEN
  403.         IF (IIPDPG.LE.0) THEN
  404.           CALL ERREUR(925)
  405.         ELSE
  406.           CALL DEPDPG(IPCHP1,UDPGE(1),UDPGE(2),UDPGE(3),IIPDPG)
  407.         ENDIF
  408.         IF (IERR.NE.0) RETURN
  409.       ENDIF
  410. C____________________________________________________________________
  411. C
  412. C     VERIFICATION DE LEUR PRESENCE
  413. C____________________________________________________________________
  414. C
  415.       NBTYPE=1
  416.       SEGINI NOTYPE
  417.       MOTYPE=NOTYPE
  418.       TYPE(1)='REAL*8'
  419.       CALL KOMCHA(IPCHE3,IPMAIL,CONM,MODEPL,MOTYPE,0,INFOS,3,IVADEP)
  420. *as xfem 2010_01_13
  421.       if (ichax1.ne.0) then
  422.         call KOMCHA(IPCHE0,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP0)
  423.         call KOMCHA(IPCHE4,IPMAIL,CONM,MODEPV,MOTYPE,1,INFOS,3,IVADEPV)
  424.       endif
  425. *fin as xfem 2010_01_13
  426.       IF (IERR.NE.0)THEN
  427.        SEGSUP NOTYPE
  428.        GOTO 9990
  429.       ENDIF
  430. C*Z      MPTVAL=IVADEP
  431. C*Z      NDDD=IVAL(/1)
  432. C*Z      IF (ldpge) NDDD=NDEP-ndpge
  433. C
  434.  
  435.       IF(KCAS.NE.3) THEN
  436.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVAST1)
  437.         SEGSUP NOTYPE
  438.         IF (IERR.NE.0) GOTO 9990
  439.         IF (ISUP.EQ.1) THEN
  440.              CALL VALCHE(IVAST1,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  441.         ENDIF
  442.       ELSE IF(KCAS.EQ.3) THEN
  443.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOHOOK,NOTYHO,1,INFOS,3,IVAST1)
  444.         IF (IERR.NE.0) THEN
  445.           NOTYPE=NOTYHO
  446.           SEGSUP NOTYPE
  447.           GOTO 9990
  448.         ENDIF
  449. **      IF (ISUP.EQ.1) THEN
  450. **           ERREUR SI ISUP = 1
  451. **      ENDIF
  452.       ENDIF
  453.  
  454.       call oooprl(1)
  455. **    write(6,*) 'piocap lock on 1'
  456. C
  457. C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  458. C
  459.       IF(KCAS.NE.3) THEN
  460.         N1PTEL=NBGS
  461.         N1EL=NBELEM
  462.         NBPTEL=N1PTEL
  463.         NEL=N1EL
  464. C
  465. C       CREATION DU MCHAML DE LA SOUS ZONE
  466. C
  467.         N2=NSTRS
  468.         SEGINI MCHAML
  469.         ICHAML(ISOUS)=MCHAML
  470.         NSR=1
  471.         NCOSOR=NSTRS
  472.         SEGINI MPTVAL
  473.         IVASTR=MPTVAL
  474.         NOMID=MOSTRS
  475.         DO 100 ICOMP=1,NSTRS
  476.           NOMCHE(ICOMP)=LESOBL(ICOMP)
  477.           TYPCHE(ICOMP)='REAL*8'
  478.           N2PTEL=0
  479.           N2EL=0
  480.           SEGINI MELVAL
  481.           IELVAL(ICOMP)=MELVAL
  482.           IVAL(ICOMP)=MELVAL
  483.  100    CONTINUE
  484. *
  485.       ELSE IF(KCAS.EQ.3) THEN
  486. *
  487. *       CREATION DU MCHAML DE LA SOUS ZONE
  488. *
  489.         N2=NHOK
  490.         SEGINI MCHAML
  491.         ICHAML(ISOUS)=MCHAML
  492. *
  493. *
  494.         NSR=1
  495.         NCOSOR=NHOK
  496.         SEGINI MPTVAL
  497.         IVAHOK=MPTVAL
  498.         NOMID=MOHOOK
  499.         NOTYPE=NOTYHO
  500.         DO 110 ICOMP=1,NHOK
  501.           NOMCHE(ICOMP)=LESOBL(ICOMP)
  502.           TYPCHE(ICOMP)=TYPE(ICOMP)
  503.           IF(TYPCHE(ICOMP).EQ.'REAL*8') THEN
  504.              MPTVAL = IVAST1
  505.              MELVA1 = IVAL(ICOMP)
  506.              segact melva1
  507.              n1ptel=melva1.velche(/1)
  508.              n1el=melva1.velche(/2)
  509.              n2ptel=melva1.ielche(/1)
  510.              n2el=melva1.ielche(/2)
  511.              SEGINI, MELVAL
  512.              MPTVAL = IVAHOK
  513.              IELVAL(ICOMP)=MELVAL
  514.              IVAL(ICOMP)=MELVAL
  515.           ELSE
  516.             N1PTEL=0
  517.             N1EL=0
  518.             N2PTEL=NBGS
  519.             N2EL=NBELEM
  520.             NBPTEL=N2PTEL
  521.             NEL=N2EL
  522.             SEGINI MELVAL
  523.             IELVAL(ICOMP)=MELVAL
  524.             IVAL(ICOMP)=MELVAL
  525.           ENDIF
  526.  110    CONTINUE
  527.       ENDIF
  528.       call oooprl(0)
  529. **    write(6,*) 'piocap lock off 1'
  530.  
  531. C
  532. *as xfem 2010_01_13
  533.       IF(MFR.EQ.1.or.MFR.EQ.63)THEN
  534.          SEGINI,MWRK1,MWRK2
  535.       ELSE IF(MFR.EQ.3)THEN
  536.          SEGINI,MWRK1,MWRK2,MWRK4
  537.       ENDIF
  538.       SEGINI,MWRK3,MWRK6
  539. C
  540. C ---------------------------------------------------
  541. C   TRANSFORMATION DES TENSEURS SI ELEMENTS MASSIFS sauf shb8
  542. C ---------------------------------------------------
  543.       IF((MFR.EQ.1.or.MFR.EQ.63).and.mele.ne.260)THEN
  544.  
  545. *as xfem 2010_01_13
  546.       IF(MFR.EQ.63)   then
  547.          SEGINI,MRACC
  548.          SEGINI,TABA
  549.       ENDIF
  550. *fin as xfem 2010_01_13
  551.       if(ideri.eq.4) then
  552.         segini mwrk5
  553.       endif
  554.  
  555. C* Mode en DEFO.GENE (DEBUT)
  556.       IF (ldpge) THEN
  557. c* revoir le signe pour IM = 1 (CAPI) ????
  558.         rsig = 1.D0 - 2.D0*IM
  559.         IF (IDIM.EQ.2) THEN
  560. C* equivalent a IF (IFOUR.EQ.-3) THEN
  561.           XE2(3,1) = rsig * UDPGE(1)
  562. c* Finir avec les rotations RX et RY ?
  563.         ELSE
  564. C*        ELSE IF (IDIM.EQ.1) THEN
  565.           IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.14) THEN
  566.             XE2(2,1) = rsig * UDPGE(1)
  567.           ELSE IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10) THEN
  568.             XE2(3,1) = rsig * UDPGE(1)
  569.           ELSE
  570. c*          ELSE IF (IFOUR.EQ.11) THEN
  571.             XE2(2,1) = rsig * UDPGE(1)
  572.             XE2(3,1) = rsig * UDPGE(2)
  573.           ENDIF
  574.         ENDIF
  575.       ENDIF
  576.  
  577. C* Mode en DEFO.GENE (FIN)
  578. C
  579. C      BOUCLE SUR LES ELEMENTS
  580. C
  581. C  preallocation en bloc des mlreel dans le cas hook
  582.       IF(KCAS.EQ.3) THEN
  583. **    write(6,*) 'piocap lock on 2'
  584.              MPTVAL=IVAHOK
  585.              MELVAL=IVAL(1)
  586.              JG=LHOO2
  587.            call oooprl(1)
  588.              do ibmn=1,min(ielche(/2),nbelem)
  589.              DO  IGAU=1,NBPTEL
  590.                 SEGINI, MLREEL
  591.                 IELCHE(IGAU,IBMN)=MLREEL
  592.              ENDDO
  593.              ENDDO
  594. **    write(6,*) 'piocap lock off 2'
  595.            call oooprl(0)
  596.       endif
  597.       DO 200 IB=1,NBELEM
  598.  
  599. *as xfem 2010_01_13
  600. *      Cacul du niveau d'enrichissement de l'élément :
  601.        nbenrj=0
  602.        if (ichax1.ne.0) then
  603.          if (nbenr1.ne.0) then
  604.           MELVA1=MCHAM1.IELVAL(1)
  605.           do i=1,NBNN
  606.             mlree1=MELVA1.IELCHE(I,IB)
  607.             tlreel(i)=mlree1
  608.             if (mlree1.ne.0) then
  609.               nbenrj=max(nbenrj,1)
  610.             endif
  611.           enddo
  612.          endif
  613.        endif
  614. *fin as xfem 2010_01_13
  615.  
  616. C  ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  617. C
  618.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  619. C
  620.          IF(IM.EQ.0)THEN
  621.             DO  INO=1,NBNN
  622.             DO  ID=1,IDIM
  623.               XE1(ID,INO)=XE(ID,INO)
  624.             ENDDO
  625.             ENDDO
  626. C
  627. *as xfem 2010_01_13
  628.             if (nbenrj.eq.0) then
  629.               MPTVAL=IVADEP
  630.             else
  631.               MPTVAL=IVADEPV
  632.             endif
  633. *fin as xfem 2010_01_13
  634.              DO  ID=1,IDIM
  635.                MELVAL=IVAL(ID)
  636.                IBMN=MIN(IB,VELCHE(/2))
  637.               DO  INO=1,NBNN
  638.                INMN=MIN(INO,VELCHE(/1))
  639.                XE2(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  640.             ENDDO
  641.             ENDDO
  642. C
  643. *as xfem 2010_01_13
  644. * Si élément enrichi :
  645.            if (nbenrj.ne.0) then
  646. *      Stockage des sauts config. initiale -> config de reference
  647.              MPTVAL=IVADEP0
  648.              DO ID=1,IDIM
  649.                MELVAL=IVAL(ID+IDIM)
  650.                IBMN=MIN(IB,VELCHE(/2))
  651.                do INO=1,NBNN
  652.                  INMN=MIN(INO,VELCHE(/1))
  653.                  TABA1(ID,INO)=VELCHE(INMN,IBMN)
  654.                ENDDO
  655.              enddo
  656. *      Stockage des sauts config. initiale -> config finale
  657.              MPTVAL=IVADEP
  658.              DO ID=1,IDIM
  659.                MELVAL=IVAL(ID+IDIM)
  660.                IBMN=MIN(IB,VELCHE(/2))
  661.                do INO=1,NBNN
  662.                  INMN=MIN(INO,VELCHE(/1))
  663.                  TABA2(ID,INO)= TABA1(ID,INO) + VELCHE(INMN,IBMN)
  664.                ENDDO
  665.              enddo
  666.            endif
  667. *fin as xfem 2010_01_13
  668.          ELSE
  669. *as xfem 2010_01_13
  670.             if (nbenrj.eq.0) then
  671.               MPTVAL=IVADEP
  672.             else
  673.               MPTVAL=IVADEPV
  674.             endif
  675. *fin as xfem 2010_01_13
  676.            DO  ID=1,IDIM
  677.                MELVAL=IVAL(ID)
  678.                IBMN=MIN(IB,VELCHE(/2))
  679.              DO  INO=1,NBNN
  680.                INMN=MIN(INO,VELCHE(/1))
  681.                XE1(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  682.            ENDDO
  683.            ENDDO
  684.             DO  INO=1,NBNN
  685.             DO  ID=1,IDIM
  686.             XE2(ID,INO)=XE(ID,INO)
  687.             ENDDO
  688.             ENDDO
  689.  
  690. *as xfem 2010_01_13
  691. * Si élément enrichi :
  692.            if (nbenrj.ne.0) then
  693. *      Stockage des sauts config. initiale -> config de reference
  694.              MPTVAL=IVADEP0
  695.              do INO=1,NBNN
  696.                DO ID=1,IDIM
  697.                  MELVAL=IVAL(ID+IDIM)
  698.                  IBMN=MIN(IB,VELCHE(/2))
  699.                  INMN=MIN(INO,VELCHE(/1))
  700.                  TABA2(ID,INO)=VELCHE(INMN,IBMN)
  701.                ENDDO
  702.              enddo
  703. *      Stockage des sauts config. initiale -> config finale
  704.              MPTVAL=IVADEP
  705.              do INO=1,NBNN
  706.                DO ID=1,IDIM
  707.                  MELVAL=IVAL(ID+IDIM)
  708.                  IBMN=MIN(IB,VELCHE(/2))
  709.                  INMN=MIN(INO,VELCHE(/1))
  710.                  TABA1(ID,INO)= TABA2(ID,INO) + VELCHE(INMN,IBMN)
  711.                ENDDO
  712.              enddo
  713.            endif
  714. *fin as xfem 2010_01_13
  715.          ENDIF
  716. C
  717. C     ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  718. C              OU LES DEFORMATIONS
  719. C              OU LES MATRICES DE HOOKE
  720. C
  721.           MPTVAL=IVAST1
  722.  
  723.           IF(KCAS.NE.3) THEN
  724.             DO  ICOMP=1,NSTRS
  725.               MELVAL=IVAL(ICOMP)
  726.               IBMN=MIN(IB,VELCHE(/2))
  727.               JGMN=VELCHE(/1)
  728.               DO  IGAU=1,NBPTEL
  729.                  IGMN=MIN(IGAU,JGMN)
  730.                  STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  731.             ENDDO
  732.             ENDDO
  733. *
  734.           ELSE IF(KCAS.EQ.3) THEN
  735.             MELVAL=IVAL(1)
  736.             IBMN=MIN(IB,IELCHE(/2))
  737.             JGMN=IELCHE(/1)
  738.             DO 241 IGAU=1,NBPTEL
  739.               IGMN=MIN(IGAU,JGMN)
  740.               MLREEL=IELCHE(IGMN,IBMN)
  741.               DO 242 IJ=1,LHOO2
  742.                 PRODDI(IGAU,IJ)=PROG(IJ)
  743.   242         CONTINUE
  744.   241       CONTINUE
  745.           ENDIF
  746.  
  747. C
  748. *as xfem 2010_01_13
  749.          if (nbenrj.eq.0) then
  750.            if(ideri.eq.5 .or. IPICA.eq.0) then
  751.              kerre=0
  752.              do icomp=1,nstrs
  753.                MELVAL=IVAL(ICOMP)
  754.                IBMN=MIN(IB,VELCHE(/2))
  755.                JGMN=VELCHE(/1)
  756.                do igau=1,nbptel
  757.                  IGMN=MIN(IGAU,JGMN)
  758.                  STRESS(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  759.                enddo
  760.              enddo
  761.            elseif(ideri.eq.4) then
  762.               call jaucau(NBNN,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  763.      &                    SHPWRK,STRESS,MWRK6,LHOOK,
  764.      &                    KCAS,mwrk5,LADIM,mele,IIPDPG)
  765.               kerre=IERR
  766.            else
  767.               CALL PIOCAF(NBNN,nbsh,IDIM,STRES1,NSTRS,NBPTEL,SHPTOT,
  768.      1              XE1,XE2, SHPWRK,STRESS,MWRK6,LHOOK,
  769.      2              IFOUR,KCAS,KERRE)
  770.            endif
  771.          else
  772.            CALL PIOCAX(NBNN,IDIM,STRES1,NSTRS,NBPTEL,IPMINT,XE1,XE2,
  773.      1        TABA,MRACC,SHPWRK,STRESS,MWRK6,LHOOK,
  774.      2        IFOUR,KCAS,KERRE)
  775.          endif
  776. *fin as xfem 2010_01_13   <
  777. C
  778.            IF(KERRE.NE.0) THEN
  779.              CALL ERREUR(716)
  780.              GO TO 9990
  781.            ENDIF
  782. C
  783. C         ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  784. C
  785.            IF(KCAS.NE.3) THEN
  786.              MPTVAL=IVASTR
  787.              DO  IGAU=1,NBPTEL
  788.                 DO  ICOMP=1,NSTRS
  789.                 MELVAL=IVAL(ICOMP)
  790.                 IBMN=MIN(IB,VELCHE(/2))
  791.                 VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  792.              ENDDO
  793.              ENDDO
  794.            ELSE IF(KCAS.EQ.3) THEN
  795.              MPTVAL=IVAHOK
  796.              MELVAL=IVAL(1)
  797.              IBMN=MIN(IB,IELCHE(/2))
  798.              DO 251 IGAU=1,NBPTEL
  799.                 MLREEL=IELCHE(IGAU,IBMN)
  800.                 DO 252 IJ=1,LHOO2
  801.                    PROG(IJ)=PRODDO(IGAU,IJ)
  802.   252           CONTINUE
  803.   251         CONTINUE
  804.            ENDIF
  805.  
  806.   200   CONTINUE
  807.  
  808. *as xfem 2010_01_27
  809.       IF(MFR.EQ.63)   then
  810.          SEGSUP,MRACC
  811.          SEGSUP,TABA
  812.       ENDIF
  813. *fin as xfem 2010_01_13
  814.       if(ideri.eq.4) then
  815.         segsup mwrk5
  816.       endif
  817. C
  818. C ---------------------------------------------------
  819. C   TRANSFORMATION DES TENSEURS SI ELEMENTS DKT
  820. C ---------------------------------------------------
  821. C  supprime le 08/06/12 car inutile et donne un resultat faux
  822. C
  823. C***********************************************************
  824. C
  825. C      ELSE IF(MFR.EQ.3.and.MELE.EQ.28)THEN
  826. C
  827. C     DO 3028  IB=1,NBELEM
  828. C
  829. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  830. C
  831. C        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  832. C
  833. C     ON CHERCHE LES DEPLACEMENTS
  834. C
  835. C        IE=1
  836. C        DO 4028 IGAU=1,NBNN
  837. C           MPTVAL=IVADEP
  838. C           DO 4028 ICOMP=1,NDEP
  839. C              MELVAL=IVAL(ICOMP)
  840. C              IGMN=MIN(IGAU,VELCHE(/1))
  841. C              IBMN=MIN(IB  ,VELCHE(/2))
  842. C              XDDL(IE)=VELCHE(IGMN,IBMN)
  843. C              IE=IE+1
  844. C4028    CONTINUE
  845. C
  846. C        CALL VPAST(XE,BPSS)
  847. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  848. C        CALL VCORLC (XE,XEL,BPSS)
  849. C        CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  850. C
  851. C
  852. C  ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  853. C
  854. C        IF(IM.EQ.0)THEN
  855. C           DO 320 INO=1,NBNN
  856. C           DO 320 ID=1,IDIM
  857. C             XE1(ID,INO)=XEL(ID,INO)
  858. C 320       CONTINUE
  859. C
  860. C           IG=-6
  861. C           MPTVAL=IVADEP
  862. C           DO 330 INO=1,NBNN
  863. C           IE=1
  864. C           IG=IG+6
  865. C            DO 330 ID=1,IDIM
  866. C              MELVAL=IVAL(ID)
  867. C              IBMN=MIN(IB,VELCHE(/2))
  868. C              INMN=MIN(INO,VELCHE(/1))
  869. C              XE2(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  870. C              IE = IE + 1
  871. C 330       CONTINUE
  872. C
  873. C        ELSE
  874. C         IG=-6
  875. C         IE = 1
  876. C         MPTVAL=IVADEP
  877. C         DO 310 INO=1,NBNN
  878. C          IE=1
  879. C          IG=IG+6
  880. C          DO 310 ID=1,IDIM
  881. C              MELVAL=IVAL(ID)
  882. C              IBMN=MIN(IB,VELCHE(/2))
  883. C              INMN=MIN(INO,VELCHE(/1))
  884. C              XE1(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  885. C              IE = IE + 1
  886. C 310      CONTINUE
  887. C           DO 315 INO=1,NBNN
  888. C           DO 315 ID=1,IDIM
  889. C           XE2(ID,INO)=XEL(ID,INO)
  890. C 315      CONTINUE
  891. C        ENDIF
  892. C
  893. C     ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  894. C
  895. C         MPTVAL=IVAST1
  896. C
  897. C         DO 340 IGAU=1,NBPTEL
  898. C          DO 340 ICOMP=1,NSTRS
  899. C              MELVAL=IVAL(ICOMP)
  900. C              IBMN=MIN(IB,VELCHE(/2))
  901. C              IGMN=MIN(IGAU,VELCHE(/1))
  902. C              STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  903. C 340     CONTINUE
  904. C
  905. C          CALL PICAF2(NBNN,2,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  906. C    1                SHPWRK,STRESS,IFOUR,1,KERRE)
  907. C
  908. C          IF(KERRE.NE.0) THEN
  909. C            CALL ERREUR(716)
  910. C            GO TO 9990
  911. C          ENDIF
  912. C
  913. C         ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  914. C
  915. C
  916. C          MPTVAL=IVASTR
  917. C          DO 350 IGAU=1,NBPTEL
  918. C             DO 350 ICOMP=1,NSTRS
  919. C             MELVAL=IVAL(ICOMP)
  920. C             IBMN=MIN(IB,VELCHE(/2))
  921. C             VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  922. C 350       CONTINUE
  923. C
  924. C
  925. C3028       CONTINUE
  926. C
  927. C --------------------
  928. C   AUTRES ELEMENTS
  929. C --------------------
  930.  
  931.         ELSE
  932. C
  933. C
  934. C      BOUCLE SUR LES ELEMENTS
  935. C
  936.          DO 400 IB=1,NBELEM
  937. C
  938. C      POUR LES AUTRES ELEMENTS ,ON COPIE LES CONTRAINTES
  939. C                                      OU LES DEFORMATIONS
  940. C                                      OU LES MATRICES DE HOOKE
  941. C       SANS LA TRANSFORMATION
  942. C
  943.  
  944.  
  945.           IF(KCAS.NE.3) THEN
  946.             MPTVAL=IVAST1
  947.             DO     IGAU=1,NBPTEL
  948.               DO     ICOMP=1,NSTRS
  949.                  MELVAL=IVAL(ICOMP)
  950.                  IBMN=MIN(IB,VELCHE(/2))
  951.                  IGMN=MIN(IGAU,VELCHE(/1))
  952.                  STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  953.             ENDDO
  954.             ENDDO
  955. C
  956.             MPTVAL=IVASTR
  957.             DO  IGAU=1,NBPTEL
  958.               DO ICOMP=1,NSTRS
  959.                 MELVAL=IVAL(ICOMP)
  960.                 IBMN=MIN(IB,VELCHE(/2))
  961.                 VELCHE(IGAU,IBMN)=STRES1(IGAU,ICOMP)
  962.             ENDDO
  963.             ENDDO
  964. *
  965.           ELSE IF(KCAS.EQ.3) THEN
  966.             MPTVAL=IVAST1
  967.             DO 461 IGAU=1,NBPTEL
  968.                  MELVAL=IVAL(1)
  969.                  IBMN=MIN(IB,IELCHE(/2))
  970.                  IGMN=MIN(IGAU,IELCHE(/1))
  971.                  ITRES1(IGAU)=IELCHE(IGMN,IBMN)
  972.   461       CONTINUE
  973. C
  974.             MPTVAL=IVAHOK
  975.             DO 471 IGAU=1,NBPTEL
  976.                 MELVAL=IVAL(1)
  977.                 IBMN=MIN(IB,IELCHE(/2))
  978.                 IELCHE(IGAU,IBMN)=ITRES1(IGAU)
  979.   471         CONTINUE
  980.           ENDIF
  981.  
  982.   400    CONTINUE
  983.         ENDIF
  984. C
  985. C     DESACTIVATION DES SEGMENTS
  986. C
  987. *as xfem 2010_01_13
  988.       IF(MFR.EQ.1.or.MFR.eq.63)THEN
  989.        SEGSUP,MWRK1,MWRK2
  990.       ELSE IF(MFR.EQ.3)THEN
  991.        SEGSUP,MWRK1,MWRK2,MWRK4
  992.       ENDIF
  993.       SEGSUP,MWRK3,MWRK6
  994.  
  995. *
  996.       CALL DTMVAL(IVADEP,1)
  997. *
  998.       IF(ISUP.EQ.1)THEN
  999.            CALL DTMVAL(IVAST1,3)
  1000.       ELSE
  1001.           CALL DTMVAL(IVAST1,1)
  1002.       ENDIF
  1003. *
  1004.       CALL DTMVAL(IVASTR,1)
  1005. *
  1006.         NOMID=MODEPL
  1007.         if(lsupdp)SEGSUP NOMID
  1008.         NOMID=MOSTRS
  1009.         if(lsupno)SEGSUP NOMID
  1010.         nomid=modepv
  1011.         if(lsupdp0) SEGSUP NOMID
  1012. *
  1013.  500  CONTINUE
  1014.       N1   =ISOUS
  1015.       SEGADJ MCHELM
  1016.  
  1017.       IRET = 1
  1018. *
  1019.       RETURN
  1020. *
  1021. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1022. *
  1023.  9990 CONTINUE
  1024. *
  1025. *     Gestion des messages d'erreur
  1026. *
  1027.       IF (IMESS.NE.0) THEN
  1028.          INTERR(1) = IB
  1029.          CALL ERREUR(IMESS)
  1030.       ENDIF
  1031. *
  1032.       CALL DTMVAL(IVADEP,1)
  1033. *
  1034.       IF(ISUP.EQ.1)THEN
  1035.            CALL DTMVAL(IVAST1,3)
  1036.       ELSE
  1037.           CALL DTMVAL(IVAST1,1)
  1038.       ENDIF
  1039. *
  1040.       CALL DTMVAL(IVASTR,3)
  1041. *
  1042.       IF(MODEPL.NE.0)THEN
  1043.        NOMID=MODEPL
  1044.        if(lsupdp)SEGSUP NOMID
  1045.       ENDIF
  1046. *
  1047.       IF(MOSTRS.NE.0)THEN
  1048.        NOMID=MOSTRS
  1049.        if(lsupno)SEGSUP NOMID
  1050.       ENDIF
  1051. *
  1052.       SEGSUP,MCHELM
  1053. *
  1054. *     write(ioimp,*) 'FIN piocap.eso si erreur'
  1055.       IRET = 0
  1056.  
  1057.       RETURN
  1058.       END
  1059.  
  1060.  
  1061.  
  1062.  
  1063.  

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