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    OF166741  25/02/21    21:18:09     12166          
  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. *      CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  249. *      IF (IERR.NE.0) THEN
  250. *        SEGSUP MCHELM
  251. *        RETURN
  252. *      ENDIF
  253. *      INFO=IPINF
  254.       MFR  =INFELE(13)
  255.       IPORE=INFELE(8)
  256.       NBG  =INFELE(6)
  257.       NBGS =INFELE(4)
  258.       NSTRS=INFELE(16)
  259.       LRE  =INFELE(9)
  260.       LW   =INFELE(7)
  261.       LHOOK=INFELE(10)
  262.       LHOO2=LHOOK*LHOOK
  263.       NDDL =INFELE(15)
  264. *      MINTE=INFELE(11)
  265.       if (infmod(/1).lt.7) goto 500
  266.       minte=infmod(7)
  267.       if (minte.eq.0) goto 500
  268.       IPMINT=MINTE
  269.       MINTE1=INFMOD(8)
  270.       ISOUS=ISOUS+1
  271.       IMACHE(ISOUS)=IPMAIL
  272.       CONCHE(ISOUS)=CONMOD
  273. *      SEGSUP INFO
  274. C
  275. C     CREATION DU TABLEAU INFOS
  276. C
  277.       INFOS(1)=0
  278.       INFOS(2)=0
  279.       INFOS(3)=NIFOUR
  280. C
  281.       INFCHE(ISOUS,1)=0
  282.       INFCHE(ISOUS,2)=0
  283.       INFCHE(ISOUS,3)=NHRM
  284.       INFCHE(ISOUS,4)=MINTE
  285.       INFCHE(ISOUS,5)=0
  286.       INFCHE(ISOUS,6)=5
  287. C
  288. C     INITIALISATION DE MINTE
  289. C
  290.       NBPGAU=POIGAU(/1)
  291. C
  292. C  Cas des modes de calculs en DEFORMATIONS GENERALISEES
  293.       CALL INFDPG(MFR,IFOUR, ldpge,ndpge)
  294. C
  295. C     ACTIVATION DU MELEME
  296. C
  297.       NBNN  =NUM(/1)
  298.       NBELEM=NUM(/2)
  299. *as xfem 2010_01_13
  300.        if (MFR.eq.63) then
  301.          NBSH=INFELE(8)
  302.        else
  303.          NBSH=NBNN
  304.        endif
  305. *fin as xfem 2010_01_13
  306.       IPPORE=0
  307.       IF(MFR.EQ.33) IPPORE=NBNN
  308. C____________________________________________________________________
  309. C
  310. C     RECHERCHE DES NOMS DE COMPOSANTES
  311. C____________________________________________________________________
  312. C
  313.       lsupno=.false.
  314.       IF(KCAS.EQ.1) THEN
  315.         if(lnomid(4).ne.0) then
  316.           nomid=lnomid(4)
  317.           mostrs=nomid
  318.           nstr=lesobl(/2)
  319.           nfac=lesfac(/2)
  320.         else
  321.          lsupno=.true.
  322.          CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  323.          endif
  324.       ENDIF
  325.       IF(KCAS.EQ.2) THEN
  326.         if(lnomid(5).ne.0) then
  327.          nomid=lnomid(5)
  328.          nstr=lesobl(/2)
  329.          mostrs=nomid
  330.          nfac=lesfac(/2)
  331.         else
  332.          lsupno=.true.
  333.          CALL IDDEFO(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  334.         endif
  335.       ENDIF
  336. *
  337.       IF(KCAS.EQ.3) THEN
  338.  
  339. *         CAS PARTICULIER DST,JOT3,JOI4 ORTHOTROPES
  340.           IF((MELE.EQ.93.OR.MELE.EQ.87.OR.MELE.EQ.88).AND.
  341.      &        CMATE.NE.'ISOTROPE')THEN
  342.             NBROBL=3
  343.             NBRFAC=0
  344.             SEGINI NOMID
  345.             LESOBL(1)='MAHO'
  346.             LESOBL(2)='V1X '
  347.             LESOBL(3)='V1Y '
  348.             NBTYPE=3
  349.             SEGINI NOTYPE
  350.             TYPE(1)='POINTEURLISTREEL'
  351.             TYPE(2)='REAL*8'
  352.             TYPE(3)='REAL*8'
  353.           ELSE
  354.             NBROBL   =1
  355.             NBRFAC   =0
  356.             SEGINI NOMID
  357.             LESOBL(1)='MAHO'
  358.             NBTYPE   =1
  359.             SEGINI NOTYPE
  360.             TYPE(1)  ='POINTEURLISTREEL'
  361.           ENDIF
  362.           NHOK = NBROBL
  363.           NFAC = NBRFAC
  364.           MOHOOK = NOMID
  365.           NOTYHO = NOTYPE
  366.       ENDIF
  367. C
  368.       if(lnomid(1).ne.0) then
  369.          nomid=lnomid(1)
  370.          modepl=nomid
  371.          ndep=lesobl(/2)
  372.          nfac=lesfac(/2)
  373.          lsupdp=.false.
  374.       else
  375.          lsupdp=.true.
  376.        CALL IDPRIM(IMODEL,0,MODEPL,NDEP,NFAC)
  377.       endif
  378.  
  379. c     cas de la derivee de JAUMANN : repere corotationnel -> global
  380.       if (ideri.eq.4) then
  381.         IF (LNOMID(3).NE.0) then
  382.           MOGRAD=LNOMID(3)
  383.           NOMID=MOGRAD
  384.           NGRA=LESOBL(/2)
  385.         ELSE
  386.           CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,NFAC)
  387.         ENDIF
  388.         LADIM=0
  389.         IF (NGRA.EQ.4) LADIM=2
  390.         IF (NGRA.EQ.9) LADIM=3
  391.         IF (LADIM.EQ.0) THEN
  392.           CALL ERREUR(26)
  393.           RETURN
  394.         ENDIF
  395.       endif
  396.  
  397. *as xfem 2010_01_13
  398. * On récupère les noms des composantes du cas massif, pour les depl. vrais
  399.       lsupdp0=.false.
  400.       IF (ichax1.ne.0) then
  401.          MFRTMP=1
  402.          call idprim(IMODEL,MFRTMP,MODEPV,NDEPV,NFACV)
  403. * as 2010_01_22
  404.          lsupdp0=.true.
  405.       ENDIF
  406. *fin as xfem 2010_01_13
  407.  
  408. C  Recherche des DDL du noeud support des def. planes generalisees
  409.       IF (ldpge) THEN
  410.         IF (IIPDPG.LE.0) THEN
  411.           CALL ERREUR(925)
  412.         ELSE
  413.           CALL DEPDPG(IPCHP1,UDPGE(1),UDPGE(2),UDPGE(3),IIPDPG)
  414.         ENDIF
  415.         IF (IERR.NE.0) RETURN
  416.       ENDIF
  417. C____________________________________________________________________
  418. C
  419. C     VERIFICATION DE LEUR PRESENCE
  420. C____________________________________________________________________
  421. C
  422.       NBTYPE=1
  423.       SEGINI NOTYPE
  424.       MOTYPE=NOTYPE
  425.       TYPE(1)='REAL*8'
  426.       CALL KOMCHA(IPCHE3,IPMAIL,CONM,MODEPL,MOTYPE,0,INFOS,3,IVADEP)
  427. *as xfem 2010_01_13
  428.       if (ichax1.ne.0) then
  429.         call KOMCHA(IPCHE0,IPMAIL,CONM,MODEPL,MOTYPE,1,INFOS,3,IVADEP0)
  430.         call KOMCHA(IPCHE4,IPMAIL,CONM,MODEPV,MOTYPE,1,INFOS,3,IVADEPV)
  431.       endif
  432. *fin as xfem 2010_01_13
  433.       IF (IERR.NE.0)THEN
  434.        SEGSUP NOTYPE
  435.        GOTO 9990
  436.       ENDIF
  437. C*Z      MPTVAL=IVADEP
  438. C*Z      NDDD=IVAL(/1)
  439. C*Z      IF (ldpge) NDDD=NDEP-ndpge
  440. C
  441.  
  442.       IF(KCAS.NE.3) THEN
  443.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOSTRS,MOTYPE,1,INFOS,3,IVAST1)
  444.         SEGSUP NOTYPE
  445.         IF (IERR.NE.0) GOTO 9990
  446.         IF (ISUP.EQ.1) THEN
  447.              CALL VALCHE(IVAST1,NSTR,IPMINT,IPPORE,MOSTRS,MELE)
  448.         ENDIF
  449.       ELSE IF(KCAS.EQ.3) THEN
  450.         CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOHOOK,NOTYHO,1,INFOS,3,IVAST1)
  451.         IF (IERR.NE.0) THEN
  452.           NOTYPE=NOTYHO
  453.           SEGSUP NOTYPE
  454.           GOTO 9990
  455.         ENDIF
  456. **      IF (ISUP.EQ.1) THEN
  457. **           ERREUR SI ISUP = 1
  458. **      ENDIF
  459.       ENDIF
  460.  
  461.       call oooprl(1)
  462. **    write(6,*) 'piocap lock on 1'
  463. C
  464. C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  465. C
  466.       IF(KCAS.NE.3) THEN
  467.         N1PTEL=NBGS
  468.         N1EL=NBELEM
  469.         NBPTEL=N1PTEL
  470.         NEL=N1EL
  471. C
  472. C       CREATION DU MCHAML DE LA SOUS ZONE
  473. C
  474.         N2=NSTRS
  475.         SEGINI MCHAML
  476.         ICHAML(ISOUS)=MCHAML
  477.         NSR=1
  478.         NCOSOR=NSTRS
  479.         SEGINI MPTVAL
  480.         IVASTR=MPTVAL
  481.         NOMID=MOSTRS
  482.         DO 100 ICOMP=1,NSTRS
  483.           NOMCHE(ICOMP)=LESOBL(ICOMP)
  484.           TYPCHE(ICOMP)='REAL*8'
  485.           N2PTEL=0
  486.           N2EL=0
  487.           SEGINI MELVAL
  488.           IELVAL(ICOMP)=MELVAL
  489.           IVAL(ICOMP)=MELVAL
  490.  100    CONTINUE
  491. *
  492.       ELSE IF(KCAS.EQ.3) THEN
  493. *
  494. *       CREATION DU MCHAML DE LA SOUS ZONE
  495. *
  496.         N2=NHOK
  497.         SEGINI MCHAML
  498.         ICHAML(ISOUS)=MCHAML
  499. *
  500. *
  501.         NSR=1
  502.         NCOSOR=NHOK
  503.         SEGINI MPTVAL
  504.         IVAHOK=MPTVAL
  505.         NOMID=MOHOOK
  506.         NOTYPE=NOTYHO
  507.         DO 110 ICOMP=1,NHOK
  508.           NOMCHE(ICOMP)=LESOBL(ICOMP)
  509.           TYPCHE(ICOMP)=TYPE(ICOMP)
  510.           IF(TYPCHE(ICOMP).EQ.'REAL*8') THEN
  511.              MPTVAL = IVAST1
  512.              MELVA1 = IVAL(ICOMP)
  513.              segact melva1
  514.              n1ptel=melva1.velche(/1)
  515.              n1el=melva1.velche(/2)
  516.              n2ptel=melva1.ielche(/1)
  517.              n2el=melva1.ielche(/2)
  518.              SEGINI, MELVAL
  519.              MPTVAL = IVAHOK
  520.              IELVAL(ICOMP)=MELVAL
  521.              IVAL(ICOMP)=MELVAL
  522.           ELSE
  523.             N1PTEL=0
  524.             N1EL=0
  525.             N2PTEL=NBGS
  526.             N2EL=NBELEM
  527.             NBPTEL=N2PTEL
  528.             NEL=N2EL
  529.             SEGINI MELVAL
  530.             IELVAL(ICOMP)=MELVAL
  531.             IVAL(ICOMP)=MELVAL
  532.           ENDIF
  533.  110    CONTINUE
  534.       ENDIF
  535.       call oooprl(0)
  536. **    write(6,*) 'piocap lock off 1'
  537.  
  538. C
  539. *as xfem 2010_01_13
  540.       IF(MFR.EQ.1.or.MFR.EQ.63)THEN
  541.          SEGINI,MWRK1,MWRK2
  542.       ELSE IF(MFR.EQ.3)THEN
  543.          SEGINI,MWRK1,MWRK2,MWRK4
  544.       ENDIF
  545.       SEGINI,MWRK3,MWRK6
  546. C
  547. C ---------------------------------------------------
  548. C   TRANSFORMATION DES TENSEURS SI ELEMENTS MASSIFS sauf shb8
  549. C ---------------------------------------------------
  550.       IF((MFR.EQ.1.or.MFR.EQ.63).and.mele.ne.260)THEN
  551.  
  552. *as xfem 2010_01_13
  553.       IF(MFR.EQ.63)   then
  554.          SEGINI,MRACC
  555.          SEGINI,TABA
  556.       ENDIF
  557. *fin as xfem 2010_01_13
  558.       if(ideri.eq.4) then
  559.         segini mwrk5
  560.       endif
  561.  
  562. C* Mode en DEFO.GENE (DEBUT)
  563.       IF (ldpge) THEN
  564. c* revoir le signe pour IM = 1 (CAPI) ????
  565.         rsig = 1.D0 - 2.D0*IM
  566.         IF (IDIM.EQ.2) THEN
  567. C* equivalent a IF (IFOUR.EQ.-3) THEN
  568.           XE2(3,1) = rsig * UDPGE(1)
  569. c* Finir avec les rotations RX et RY ?
  570.         ELSE
  571. C*        ELSE IF (IDIM.EQ.1) THEN
  572.           IF (IFOUR.EQ.7 .OR. IFOUR.EQ.8 .OR. IFOUR.EQ.14) THEN
  573.             XE2(2,1) = rsig * UDPGE(1)
  574.           ELSE IF (IFOUR.EQ.9 .OR. IFOUR.EQ.10) THEN
  575.             XE2(3,1) = rsig * UDPGE(1)
  576.           ELSE
  577. c*          ELSE IF (IFOUR.EQ.11) THEN
  578.             XE2(2,1) = rsig * UDPGE(1)
  579.             XE2(3,1) = rsig * UDPGE(2)
  580.           ENDIF
  581.         ENDIF
  582.       ENDIF
  583.  
  584. C* Mode en DEFO.GENE (FIN)
  585. C
  586. C      BOUCLE SUR LES ELEMENTS
  587. C
  588. C  preallocation en bloc des mlreel dans le cas hook
  589.       IF(KCAS.EQ.3) THEN
  590. **    write(6,*) 'piocap lock on 2'
  591.              MPTVAL=IVAHOK
  592.              MELVAL=IVAL(1)
  593.              JG=LHOO2
  594.            call oooprl(1)
  595.              do ibmn=1,min(ielche(/2),nbelem)
  596.              DO  IGAU=1,NBPTEL
  597.                 SEGINI, MLREEL
  598.                 IELCHE(IGAU,IBMN)=MLREEL
  599.              ENDDO
  600.              ENDDO
  601. **    write(6,*) 'piocap lock off 2'
  602.            call oooprl(0)
  603.       endif
  604.       DO 200 IB=1,NBELEM
  605.  
  606. *as xfem 2010_01_13
  607. *      Cacul du niveau d'enrichissement de l'élément :
  608.        nbenrj=0
  609.        if (ichax1.ne.0) then
  610.          if (nbenr1.ne.0) then
  611.           MELVA1=MCHAM1.IELVAL(1)
  612.           do i=1,NBNN
  613.             mlree1=MELVA1.IELCHE(I,IB)
  614.             tlreel(i)=mlree1
  615.             if (mlree1.ne.0) then
  616.               nbenrj=max(nbenrj,1)
  617.             endif
  618.           enddo
  619.          endif
  620.        endif
  621. *fin as xfem 2010_01_13
  622.  
  623. C  ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  624. C
  625.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  626. C
  627.          IF(IM.EQ.0)THEN
  628.             DO  INO=1,NBNN
  629.             DO  ID=1,IDIM
  630.               XE1(ID,INO)=XE(ID,INO)
  631.             ENDDO
  632.             ENDDO
  633. C
  634. *as xfem 2010_01_13
  635.             if (nbenrj.eq.0) then
  636.               MPTVAL=IVADEP
  637.             else
  638.               MPTVAL=IVADEPV
  639.             endif
  640. *fin as xfem 2010_01_13
  641.              DO  ID=1,IDIM
  642.                MELVAL=IVAL(ID)
  643.                IBMN=MIN(IB,VELCHE(/2))
  644.               DO  INO=1,NBNN
  645.                INMN=MIN(INO,VELCHE(/1))
  646.                XE2(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  647.             ENDDO
  648.             ENDDO
  649. C
  650. *as xfem 2010_01_13
  651. * Si élément enrichi :
  652.            if (nbenrj.ne.0) then
  653. *      Stockage des sauts config. initiale -> config de reference
  654.              MPTVAL=IVADEP0
  655.              DO ID=1,IDIM
  656.                MELVAL=IVAL(ID+IDIM)
  657.                IBMN=MIN(IB,VELCHE(/2))
  658.                do INO=1,NBNN
  659.                  INMN=MIN(INO,VELCHE(/1))
  660.                  TABA1(ID,INO)=VELCHE(INMN,IBMN)
  661.                ENDDO
  662.              enddo
  663. *      Stockage des sauts config. initiale -> config finale
  664.              MPTVAL=IVADEP
  665.              DO ID=1,IDIM
  666.                MELVAL=IVAL(ID+IDIM)
  667.                IBMN=MIN(IB,VELCHE(/2))
  668.                do INO=1,NBNN
  669.                  INMN=MIN(INO,VELCHE(/1))
  670.                  TABA2(ID,INO)= TABA1(ID,INO) + VELCHE(INMN,IBMN)
  671.                ENDDO
  672.              enddo
  673.            endif
  674. *fin as xfem 2010_01_13
  675.          ELSE
  676. *as xfem 2010_01_13
  677.             if (nbenrj.eq.0) then
  678.               MPTVAL=IVADEP
  679.             else
  680.               MPTVAL=IVADEPV
  681.             endif
  682. *fin as xfem 2010_01_13
  683.            DO  ID=1,IDIM
  684.                MELVAL=IVAL(ID)
  685.                IBMN=MIN(IB,VELCHE(/2))
  686.              DO  INO=1,NBNN
  687.                INMN=MIN(INO,VELCHE(/1))
  688.                XE1(ID,INO)=XE(ID,INO)+VELCHE(INMN,IBMN)
  689.            ENDDO
  690.            ENDDO
  691.             DO  INO=1,NBNN
  692.             DO  ID=1,IDIM
  693.             XE2(ID,INO)=XE(ID,INO)
  694.             ENDDO
  695.             ENDDO
  696.  
  697. *as xfem 2010_01_13
  698. * Si élément enrichi :
  699.            if (nbenrj.ne.0) then
  700. *      Stockage des sauts config. initiale -> config de reference
  701.              MPTVAL=IVADEP0
  702.              do INO=1,NBNN
  703.                DO ID=1,IDIM
  704.                  MELVAL=IVAL(ID+IDIM)
  705.                  IBMN=MIN(IB,VELCHE(/2))
  706.                  INMN=MIN(INO,VELCHE(/1))
  707.                  TABA2(ID,INO)=VELCHE(INMN,IBMN)
  708.                ENDDO
  709.              enddo
  710. *      Stockage des sauts config. initiale -> config finale
  711.              MPTVAL=IVADEP
  712.              do INO=1,NBNN
  713.                DO ID=1,IDIM
  714.                  MELVAL=IVAL(ID+IDIM)
  715.                  IBMN=MIN(IB,VELCHE(/2))
  716.                  INMN=MIN(INO,VELCHE(/1))
  717.                  TABA1(ID,INO)= TABA2(ID,INO) + VELCHE(INMN,IBMN)
  718.                ENDDO
  719.              enddo
  720.            endif
  721. *fin as xfem 2010_01_13
  722.          ENDIF
  723. C
  724. C     ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  725. C              OU LES DEFORMATIONS
  726. C              OU LES MATRICES DE HOOKE
  727. C
  728.           MPTVAL=IVAST1
  729.  
  730.           IF(KCAS.NE.3) THEN
  731.             DO  ICOMP=1,NSTRS
  732.               MELVAL=IVAL(ICOMP)
  733.               IBMN=MIN(IB,VELCHE(/2))
  734.               JGMN=VELCHE(/1)
  735.               DO  IGAU=1,NBPTEL
  736.                  IGMN=MIN(IGAU,JGMN)
  737.                  STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  738.             ENDDO
  739.             ENDDO
  740. *
  741.           ELSE IF(KCAS.EQ.3) THEN
  742.             MELVAL=IVAL(1)
  743.             IBMN=MIN(IB,IELCHE(/2))
  744.             JGMN=IELCHE(/1)
  745.             DO 241 IGAU=1,NBPTEL
  746.               IGMN=MIN(IGAU,JGMN)
  747.               MLREEL=IELCHE(IGMN,IBMN)
  748.               DO 242 IJ=1,LHOO2
  749.                 PRODDI(IGAU,IJ)=PROG(IJ)
  750.   242         CONTINUE
  751.   241       CONTINUE
  752.           ENDIF
  753.  
  754. C
  755. *as xfem 2010_01_13
  756.          if (nbenrj.eq.0) then
  757.            if(ideri.eq.5 .or. IPICA.eq.0) then
  758.              kerre=0
  759.              do icomp=1,nstrs
  760.                MELVAL=IVAL(ICOMP)
  761.                IBMN=MIN(IB,VELCHE(/2))
  762.                JGMN=VELCHE(/1)
  763.                do igau=1,nbptel
  764.                  IGMN=MIN(IGAU,JGMN)
  765.                  STRESS(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  766.                enddo
  767.              enddo
  768.            elseif(ideri.eq.4) then
  769.               call jaucau(NBNN,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  770.      &                    SHPWRK,STRESS,MWRK6,LHOOK,
  771.      &                    KCAS,mwrk5,LADIM,mele,IIPDPG)
  772.               kerre=IERR
  773.            else
  774.               CALL PIOCAF(NBNN,nbsh,IDIM,STRES1,NSTRS,NBPTEL,SHPTOT,
  775.      1              XE1,XE2, SHPWRK,STRESS,MWRK6,LHOOK,
  776.      2              IFOUR,KCAS,KERRE)
  777.            endif
  778.          else
  779.            CALL PIOCAX(NBNN,IDIM,STRES1,NSTRS,NBPTEL,IPMINT,XE1,XE2,
  780.      1        TABA,MRACC,SHPWRK,STRESS,MWRK6,LHOOK,
  781.      2        IFOUR,KCAS,KERRE)
  782.          endif
  783. *fin as xfem 2010_01_13   <
  784. C
  785.            IF(KERRE.NE.0) THEN
  786.              CALL ERREUR(716)
  787.              GO TO 9990
  788.            ENDIF
  789. C
  790. C         ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  791. C
  792.            IF(KCAS.NE.3) THEN
  793.              MPTVAL=IVASTR
  794.              DO  IGAU=1,NBPTEL
  795.                 DO  ICOMP=1,NSTRS
  796.                 MELVAL=IVAL(ICOMP)
  797.                 IBMN=MIN(IB,VELCHE(/2))
  798.                 VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  799.              ENDDO
  800.              ENDDO
  801.            ELSE IF(KCAS.EQ.3) THEN
  802.              MPTVAL=IVAHOK
  803.              MELVAL=IVAL(1)
  804.              IBMN=MIN(IB,IELCHE(/2))
  805.              DO 251 IGAU=1,NBPTEL
  806.                 MLREEL=IELCHE(IGAU,IBMN)
  807.                 DO 252 IJ=1,LHOO2
  808.                    PROG(IJ)=PRODDO(IGAU,IJ)
  809.   252           CONTINUE
  810.   251         CONTINUE
  811.            ENDIF
  812.  
  813.   200   CONTINUE
  814.  
  815. *as xfem 2010_01_27
  816.       IF(MFR.EQ.63)   then
  817.          SEGSUP,MRACC
  818.          SEGSUP,TABA
  819.       ENDIF
  820. *fin as xfem 2010_01_13
  821.       if(ideri.eq.4) then
  822.         segsup mwrk5
  823.       endif
  824. C
  825. C ---------------------------------------------------
  826. C   TRANSFORMATION DES TENSEURS SI ELEMENTS DKT
  827. C ---------------------------------------------------
  828. C  supprime le 08/06/12 car inutile et donne un resultat faux
  829. C
  830. C***********************************************************
  831. C
  832. C      ELSE IF(MFR.EQ.3.and.MELE.EQ.28)THEN
  833. C
  834. C     DO 3028  IB=1,NBELEM
  835. C
  836. C     ON CHERCHE LES COORDONNEES DES NOEUDS DE L ELEMENT IB
  837. C
  838. C        CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  839. C
  840. C     ON CHERCHE LES DEPLACEMENTS
  841. C
  842. C        IE=1
  843. C        DO 4028 IGAU=1,NBNN
  844. C           MPTVAL=IVADEP
  845. C           DO 4028 ICOMP=1,NDEP
  846. C              MELVAL=IVAL(ICOMP)
  847. C              IGMN=MIN(IGAU,VELCHE(/1))
  848. C              IBMN=MIN(IB  ,VELCHE(/2))
  849. C              XDDL(IE)=VELCHE(IGMN,IBMN)
  850. C              IE=IE+1
  851. C4028    CONTINUE
  852. C
  853. C        CALL VPAST(XE,BPSS)
  854. C     BPSS    STOCKE LA MATRICE DE PASSAGE
  855. C        CALL VCORLC (XE,XEL,BPSS)
  856. C        CALL MATVEC(XDDL,XDDLOC,BPSS,6)
  857. C
  858. C
  859. C  ON RECUPERE LES COORDONNEES DE DEUX CONFIGURATIONS
  860. C
  861. C        IF(IM.EQ.0)THEN
  862. C           DO 320 INO=1,NBNN
  863. C           DO 320 ID=1,IDIM
  864. C             XE1(ID,INO)=XEL(ID,INO)
  865. C 320       CONTINUE
  866. C
  867. C           IG=-6
  868. C           MPTVAL=IVADEP
  869. C           DO 330 INO=1,NBNN
  870. C           IE=1
  871. C           IG=IG+6
  872. C            DO 330 ID=1,IDIM
  873. C              MELVAL=IVAL(ID)
  874. C              IBMN=MIN(IB,VELCHE(/2))
  875. C              INMN=MIN(INO,VELCHE(/1))
  876. C              XE2(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  877. C              IE = IE + 1
  878. C 330       CONTINUE
  879. C
  880. C        ELSE
  881. C         IG=-6
  882. C         IE = 1
  883. C         MPTVAL=IVADEP
  884. C         DO 310 INO=1,NBNN
  885. C          IE=1
  886. C          IG=IG+6
  887. C          DO 310 ID=1,IDIM
  888. C              MELVAL=IVAL(ID)
  889. C              IBMN=MIN(IB,VELCHE(/2))
  890. C              INMN=MIN(INO,VELCHE(/1))
  891. C              XE1(ID,INO)=XEL(ID,INO)+XDDLOC(IE+IG)
  892. C              IE = IE + 1
  893. C 310      CONTINUE
  894. C           DO 315 INO=1,NBNN
  895. C           DO 315 ID=1,IDIM
  896. C           XE2(ID,INO)=XEL(ID,INO)
  897. C 315      CONTINUE
  898. C        ENDIF
  899. C
  900. C     ON RECUPERE LES CONTRAINTES DE KIRCHHOFF
  901. C
  902. C         MPTVAL=IVAST1
  903. C
  904. C         DO 340 IGAU=1,NBPTEL
  905. C          DO 340 ICOMP=1,NSTRS
  906. C              MELVAL=IVAL(ICOMP)
  907. C              IBMN=MIN(IB,VELCHE(/2))
  908. C              IGMN=MIN(IGAU,VELCHE(/1))
  909. C              STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  910. C 340     CONTINUE
  911. C
  912. C          CALL PICAF2(NBNN,2,STRES1,NSTRS,NBPTEL,SHPTOT,XE1,XE2,
  913. C    1                SHPWRK,STRESS,IFOUR,1,KERRE)
  914. C
  915. C          IF(KERRE.NE.0) THEN
  916. C            CALL ERREUR(716)
  917. C            GO TO 9990
  918. C          ENDIF
  919. C
  920. C         ON REMPLIT LES SEGMENTS MELVALS CORRESPONDANTS
  921. C
  922. C
  923. C          MPTVAL=IVASTR
  924. C          DO 350 IGAU=1,NBPTEL
  925. C             DO 350 ICOMP=1,NSTRS
  926. C             MELVAL=IVAL(ICOMP)
  927. C             IBMN=MIN(IB,VELCHE(/2))
  928. C             VELCHE(IGAU,IBMN)=STRESS(IGAU,ICOMP)
  929. C 350       CONTINUE
  930. C
  931. C
  932. C3028       CONTINUE
  933. C
  934. C --------------------
  935. C   AUTRES ELEMENTS
  936. C --------------------
  937.  
  938.         ELSE
  939. C
  940. C
  941. C      BOUCLE SUR LES ELEMENTS
  942. C
  943.          DO 400 IB=1,NBELEM
  944. C
  945. C      POUR LES AUTRES ELEMENTS ,ON COPIE LES CONTRAINTES
  946. C                                      OU LES DEFORMATIONS
  947. C                                      OU LES MATRICES DE HOOKE
  948. C       SANS LA TRANSFORMATION
  949. C
  950.  
  951.  
  952.           IF(KCAS.NE.3) THEN
  953.             MPTVAL=IVAST1
  954.             DO     IGAU=1,NBPTEL
  955.               DO     ICOMP=1,NSTRS
  956.                  MELVAL=IVAL(ICOMP)
  957.                  IBMN=MIN(IB,VELCHE(/2))
  958.                  IGMN=MIN(IGAU,VELCHE(/1))
  959.                  STRES1(IGAU,ICOMP)=VELCHE(IGMN,IBMN)
  960.             ENDDO
  961.             ENDDO
  962. C
  963.             MPTVAL=IVASTR
  964.             DO  IGAU=1,NBPTEL
  965.               DO ICOMP=1,NSTRS
  966.                 MELVAL=IVAL(ICOMP)
  967.                 IBMN=MIN(IB,VELCHE(/2))
  968.                 VELCHE(IGAU,IBMN)=STRES1(IGAU,ICOMP)
  969.             ENDDO
  970.             ENDDO
  971. *
  972.           ELSE IF(KCAS.EQ.3) THEN
  973.             MPTVAL=IVAST1
  974.             DO 461 IGAU=1,NBPTEL
  975.                  MELVAL=IVAL(1)
  976.                  IBMN=MIN(IB,IELCHE(/2))
  977.                  IGMN=MIN(IGAU,IELCHE(/1))
  978.                  ITRES1(IGAU)=IELCHE(IGMN,IBMN)
  979.   461       CONTINUE
  980. C
  981.             MPTVAL=IVAHOK
  982.             DO 471 IGAU=1,NBPTEL
  983.                 MELVAL=IVAL(1)
  984.                 IBMN=MIN(IB,IELCHE(/2))
  985.                 IELCHE(IGAU,IBMN)=ITRES1(IGAU)
  986.   471         CONTINUE
  987.           ENDIF
  988.  
  989.   400    CONTINUE
  990.         ENDIF
  991. C
  992. C     DESACTIVATION DES SEGMENTS
  993. C
  994. *as xfem 2010_01_13
  995.       IF(MFR.EQ.1.or.MFR.eq.63)THEN
  996.        SEGSUP,MWRK1,MWRK2
  997.       ELSE IF(MFR.EQ.3)THEN
  998.        SEGSUP,MWRK1,MWRK2,MWRK4
  999.       ENDIF
  1000.       SEGSUP,MWRK3,MWRK6
  1001.  
  1002. *
  1003.       CALL DTMVAL(IVADEP,1)
  1004. *
  1005.       IF(ISUP.EQ.1)THEN
  1006.            CALL DTMVAL(IVAST1,3)
  1007.       ELSE
  1008.           CALL DTMVAL(IVAST1,1)
  1009.       ENDIF
  1010. *
  1011.       CALL DTMVAL(IVASTR,1)
  1012. *
  1013.         NOMID=MODEPL
  1014.         if(lsupdp)SEGSUP NOMID
  1015.         NOMID=MOSTRS
  1016.         if(lsupno)SEGSUP NOMID
  1017.         nomid=modepv
  1018.         if(lsupdp0) SEGSUP NOMID
  1019. *
  1020.  500  CONTINUE
  1021.       N1   =ISOUS
  1022.       SEGADJ MCHELM
  1023.  
  1024.       IRET = 1
  1025. *
  1026.       RETURN
  1027. *
  1028. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  1029. *
  1030.  9990 CONTINUE
  1031. *
  1032. *     Gestion des messages d'erreur
  1033. *
  1034.       IF (IMESS.NE.0) THEN
  1035.          INTERR(1) = IB
  1036.          CALL ERREUR(IMESS)
  1037.       ENDIF
  1038. *
  1039.       CALL DTMVAL(IVADEP,1)
  1040. *
  1041.       IF(ISUP.EQ.1)THEN
  1042.            CALL DTMVAL(IVAST1,3)
  1043.       ELSE
  1044.           CALL DTMVAL(IVAST1,1)
  1045.       ENDIF
  1046. *
  1047.       CALL DTMVAL(IVASTR,3)
  1048. *
  1049.       IF(MODEPL.NE.0)THEN
  1050.        NOMID=MODEPL
  1051.        if(lsupdp)SEGSUP NOMID
  1052.       ENDIF
  1053. *
  1054.       IF(MOSTRS.NE.0)THEN
  1055.        NOMID=MOSTRS
  1056.        if(lsupno)SEGSUP NOMID
  1057.       ENDIF
  1058. *
  1059.       SEGSUP,MCHELM
  1060. *
  1061. *     write(ioimp,*) 'FIN piocap.eso si erreur'
  1062.       IRET = 0
  1063.  
  1064.       RETURN
  1065.       END
  1066.  
  1067.  
  1068.  

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