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

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