Télécharger la plaquette Cast3M


fr en

Télécharger prinpo.eso

Retour à la liste

Numérotation des lignes : 

prinpo

  1. C PRINPO    SOURCE    OF166741  24/10/07    21:15:41     12016          
  2.       SUBROUTINE PRINPO(IPCHE1,MMM,IPCHE2,IPMODL,IPSTRS,IRET)
  3. C=======================================================================
  4. C
  5. C  entr{es :
  6. C  ========
  7. C
  8. C   IPCHE1 =pointeur sur un MCHAML de CONTRAINTES ou de DEFORMATIONS
  9. C     MMM  =motcle pour les COQUES ( sortie sur la peau SUP INF OU MOYE)
  10. C   IPCHE2 =pointeur sur un MCHAML de CARACTERISTIQUES
  11. C   IPMODL =pointeur sur un MODELE
  12. C
  13. C  sorties :
  14. C  =======
  15. C
  16. C   IPSTRS =pointeur sur un MCHAML de CONTRAINTES PRINCIPALES
  17. C     IRET =1  OU  0   SUIVANT SUCCES OU PAS (MESSAGE D'ERREUR
  18. C                                             imprim{ dans ce cas)
  19. C
  20. C   Passage aux nouveaux Chamelem par S.RAMAHANDRY le 21/09/90
  21. C
  22. C=======================================================================
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8(A-H,O-Z)
  25.       INTEGER ISUP2
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCHAMP
  30. -INC SMCHAML
  31. -INC SMINTE
  32. -INC SMMODEL
  33. -INC SMCOORD
  34. -INC SMELEME
  35. C
  36.       SEGMENT MWRK1
  37.          REAL*8  XEL(3,NBNN)
  38.       ENDSEGMENT
  39. C
  40.       SEGMENT MWRK2
  41.          REAL*8 TXR(3,3,NBNN) ,TH(NBNN)
  42.       ENDSEGMENT
  43. C
  44.       SEGMENT NOTYPE
  45.         CHARACTER*16 TYPE(NBTYPE)
  46.       ENDSEGMENT
  47. C
  48.       SEGMENT MPTVAL
  49.         INTEGER IPOS(NS)    ,NSOF(NS)
  50.         INTEGER      IVAL(NCOSOU)
  51.         CHARACTER*16 TYVAL(NCOSOU)
  52.       ENDSEGMENT
  53. C
  54.       PARAMETER ( NINF=3 )
  55.       INTEGER INFOS(NINF)
  56. C
  57.       CHARACTER*4 MOTCLE(6),MMM
  58.       CHARACTER*(NCONCH) CONM
  59.       LOGICAL lsuppr,lsupno
  60.       DIMENSION A(3,3),D(3),S(3,3),BPSS(3,3),SIG(9),V1(4)
  61. C
  62.       DATA MOTCLE/'SUP ','MOYE','INF ','SUPE','INFE','TRID'/
  63.       DATA XZER,UN,DEUX/0.D0,1.D0,2.D0/
  64. C
  65.       LSUPNO=.FALSE.
  66.       LSUPpR=.FALSE.
  67.       ISUP2=0
  68.       IDIMM=IDIM
  69.       XFLOT =XZER
  70.       IF(MMM.EQ.MOTCLE(1)) XFLOT= UN
  71.       IF(MMM.EQ.MOTCLE(4)) XFLOT= UN
  72.       IF(MMM.EQ.MOTCLE(2)) XFLOT= XZER
  73.       IF(MMM.EQ.MOTCLE(3)) XFLOT=-UN
  74.       IF(MMM.EQ.MOTCLE(5)) XFLOT=-UN
  75. C
  76.       LETRID=0
  77.       IF(MMM.EQ.MOTCLE(6)) LETRID=1
  78.  
  79.       NHRM=NIFOUR
  80. C
  81.       IRET = 0
  82. C
  83.       ICONT=0
  84.       IDEFO=0
  85.       MCHELM=IPCHE1
  86.       SEGACT MCHELM
  87.       IF (TITCHE .EQ.'CONTRAINTES' ) ICONT = 1
  88.       IF (TITCHE .EQ.'DEFORMATIONS') IDEFO = 1
  89. C CLB
  90. C CLB  DANS LE CAS DES DEFORMATIONS IL FAUT MULTIPLIER LES GAMMA PAR 0.5
  91. C CLB
  92.  
  93.       XMULIJ=ICONT + IDEFO/DEUX 
  94. C
  95. C ERREUR  IL FAUT UN CHAMELEM DE SOUS TYPE CONTRAINTES OU DEFORMATIONS
  96. C
  97.       IF (ICONT.NE.1 .AND. IDEFO.NE.1) THEN
  98.       MOTERR(1:24)='CONTRAINTES'
  99.       MOTERR(25:48)='DEFORMATIONS'
  100.       CALL ERREUR(109)
  101.       RETURN
  102.       ENDIF
  103. C
  104. C     Verification du lieu support du MCHAML de contraintes
  105. C
  106.  
  107. C Contraintes / Deformations : REDU et Verification du lieu support
  108.       CALL QUESUP (IPMODL,IPCHE1,5,0,ISUP1,IRET1)
  109.       IF (ISUP1.GT.1) RETURN
  110.  
  111. C Caracteristiques : REDU et Verification du lieu support
  112. ****  IPCHE2 = 0
  113.       IF (IPCHE2.NE.0) THEN
  114.         CALL QUESUP (IPMODL,IPCHE2,5,0,ISUP2,IRET2)
  115.         IF (ISUP2.GT.1) RETURN
  116.       ENDIF
  117. C
  118. C     ACTIVATION DU MODELE
  119. C
  120.       MMODEL=IPMODL
  121.       SEGACT MMODEL
  122.       NSOUS=KMODEL(/1)
  123. C
  124. C     CREATION DU MCHELM
  125. C
  126.       N1=NSOUS
  127.       L1=23
  128.       N3=6
  129.       SEGINI MCHELM
  130.       TITCHE='CONTRAINTES PRINCIPALES'
  131. C CLB
  132. C CLB MODIFICATION DU TITRE DANS LE CAS DES DEFORMATIONS
  133. C CLB 
  134.       IF (IDEFO .EQ. 1) THEN
  135.          TITCHE='DEFORMATIONS PRINCIPALES'
  136.       ENDIF
  137.       IFOCHE=IFOUR
  138.       IPSTRS=MCHELM
  139. C____________________________________________________________________
  140. C
  141. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  142. C____________________________________________________________________
  143. C
  144.       DO 500 ISOUS=1,NSOUS
  145. C
  146.       IVECT =0
  147.       IVACAR=0
  148.       IVACOM=0
  149.       NCARF =0
  150.       NCARA =0
  151.       NPRIN =0
  152.       MOCARA=0
  153.       MOCOMP=0
  154.       MOSPRI=0
  155. C
  156. C        ON RECUPERE L'INFORMATION GENERALE
  157. C
  158.          IMODEL=KMODEL(ISOUS)
  159.          SEGACT IMODEL
  160.          IPMAIL=IMAMOD
  161.          CONM  =CONMOD
  162. C
  163. C   COQUE INTEGREE OU PAS ?
  164. C
  165.          NPINT=INFMOD(1)
  166. C
  167.          IMACHE(ISOUS)=IPMAIL
  168.          CONCHE(ISOUS)=CONMOD
  169. C
  170. C        TRAITEMENT DU MODELE
  171. C
  172.          MELE=NEFMOD
  173.          MELEME=IMAMOD
  174. C____________________________________________________________________
  175. C
  176. C     INFORMATION SUR L'ELEMENT FINI
  177. C____________________________________________________________________
  178. C
  179. C         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  180. C         IF (IERR.NE.0) THEN
  181. C           SEGSUP MCHELM
  182. C           RETURN
  183. C         ENDIF
  184. C         INFO=IPINF
  185.          MFR  =INFELE(13)
  186.          NBGS =INFELE(4)
  187.          NSTRS=INFELE(16)
  188. C         MINTE=INFELE(11)
  189.          MINTE=INFMOD(7)
  190.          IPMINT=MINTE
  191.          MINTE1=INFMOD(8)
  192. C         SEGSUP,INFO
  193. C
  194. C        CREATION DU TABLEAU INFOS
  195. C
  196.          CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  197.          IF (IRTD.EQ.0) GOTO 9990
  198. C
  199.          INFCHE(ISOUS,1)=0
  200.          INFCHE(ISOUS,2)=0
  201.          INFCHE(ISOUS,3)=NHRM
  202.          INFCHE(ISOUS,4)=MINTE
  203.          INFCHE(ISOUS,5)=0
  204.          INFCHE(ISOUS,6)=5
  205. C
  206. C        INITIALISATION DE MINTE
  207. C
  208.          SEGACT MINTE
  209.          NBPGAU=POIGAU(/1)
  210. C
  211. C        ACTIVATION DU MELEME
  212. C
  213.          SEGACT MELEME
  214.          NBNN  =NUM(/1)
  215.          NBELEM=NUM(/2)
  216.          IPPORE=0
  217.          IF(MFR.EQ.33) IPPORE=NBNN
  218.  
  219. C____________________________________________________________________
  220. C
  221. C        RECHERCHE DES NOMS DE COMPOSANTES
  222. C____________________________________________________________________
  223. C
  224.          lsupno=.false.
  225.          IF(ICONT.EQ.1) THEN
  226.           if(lnomid(4).ne.0) then
  227.              nomid=lnomid(4)
  228.              segact nomid
  229.              mocomp=nomid
  230.              ncomp=lesobl(/2)
  231.              nfac=lesfac(/2)
  232.            else
  233.             lsupno=.true.
  234.             CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  235.            endif
  236.          ELSE IF(IDEFO.EQ.1) THEN
  237.            if(lnomid(5).ne.0) then
  238.              nomid=lnomid(5)
  239.              segact nomid
  240.              ncomp=lesobl(/2)
  241.              mocomp=nomid
  242.             else
  243.              lsupno=.true.
  244.              CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  245.             endif
  246.          ENDIF
  247. C
  248.         if(lnomid(9).ne.0) then
  249.           nomid=lnomid(9)
  250.           segact nomid
  251.           mospri=nomid
  252.           nprin=lesobl(/2)
  253.           nfac=lesfac(/2)
  254.           lsuppr=.false.
  255.         else
  256.           lsuppr=.true.
  257.          CALL IDPRIN(MFR,IFOUR,MOSPRI,NPRIN,NFAC)
  258.         endif
  259. C
  260. C____________________________________________________________________
  261. C
  262. C        VERIFICATION DE LEUR PRESENCE
  263. C____________________________________________________________________
  264. C
  265.          NBTYPE=1
  266.          SEGINI NOTYPE
  267.          MOTYPE=NOTYPE
  268.          TYPE(1)='REAL*8'
  269.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
  270.      1                          MOTYPE,1,INFOS,3,IVACOM)
  271.          SEGSUP NOTYPE
  272.          IF (IERR.NE.0) GOTO 9990
  273.          IF (ISUP1.EQ.1) THEN
  274.            CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE,MOCOMP,MELE)
  275.          ENDIF
  276. C
  277. C        RECHERCHE DE LA TAILLE DES MELVAL DES CONTRAINTES
  278. C
  279.          N1PTEL=0
  280.          N1EL=0
  281.          MPTVAL=IVACOM
  282.          DO 111 IO=1,NCOMP
  283.            MELVAL=IVAL(IO)
  284.            N1PTEL=MAX(N1PTEL,VELCHE(/1))
  285.  111     CONTINUE
  286.          NBGCOM=N1PTEL
  287. C
  288.          N1EL=NBELEM
  289. C
  290. C        CREATION DU MCHAML DE LA SOUS ZONE
  291. C
  292.          N2=NPRIN
  293.          SEGINI MCHAML
  294.          ICHAML(ISOUS)=MCHAML
  295.          NS=1
  296.          NCOSOU=NPRIN
  297.          SEGINI MPTVAL
  298.          IVAPRI=MPTVAL
  299.          NOMID=MOSPRI
  300.          SEGACT NOMID
  301.          DO 100 ICOMP=1,NPRIN
  302.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  303.             TYPCHE(ICOMP)='REAL*8'
  304.             N2PTEL=0
  305.             N2EL=0
  306.             SEGINI MELVAL
  307.             IELVAL(ICOMP)=MELVAL
  308.             IVAL(ICOMP)=MELVAL
  309.  100     CONTINUE
  310. C____________________________________________________________________
  311. C
  312. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
  313. C____________________________________________________________________
  314. C
  315.          NBROBL=0
  316.          NBRFAC=0
  317.          MOCARA=0
  318. C
  319. C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  320. C
  321.          IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  322.             NBROBL=1
  323.             NBRFAC=1
  324.             SEGINI NOMID
  325.             MOCARA=NOMID
  326.             LESOBL(1)='EPAI'
  327.             LESFAC(1)='EXCE'
  328. C
  329. C CARACTERISTIQUES POUR LES LINESPRING
  330. C
  331.          ELSE IF (MFR.EQ.15) THEN
  332.             NBROBL=1
  333.             SEGINI NOMID
  334.             MOCARA=NOMID
  335.             LESOBL(1)='EPAI'
  336.          ENDIF
  337. C
  338.       IF (MOCARA.NE.0) THEN
  339.          IF (IPCHE2.NE.0) THEN
  340.             NBTYPE=1
  341.             SEGINI NOTYPE
  342.             MOTYPE=NOTYPE
  343.             TYPE(1)='REAL*8'
  344.             CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
  345.      1                          MOTYPE,1,INFOS,3,IVACAR)
  346.             SEGSUP NOTYPE
  347.             IF (IERR.NE.0) GOTO 9990
  348.                IF (IVECT.EQ.1) THEN
  349.                   MPTVAL=IVACAR
  350.                   IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
  351. C
  352. C                    MOT CLE VECT EN CAS DE CONVERSION
  353. C
  354.                      IVECT=2
  355.                      NOMID=MOCARA
  356.                      SEGACT NOMID
  357.                      NBRFAC=NBRFAC+2
  358.                      SEGADJ NOMID
  359.                      MOCARA=NOMID
  360.                      LESFAC(NBRFAC-2)='VX  '
  361.                      LESFAC(NBRFAC-1)='VY  '
  362.                      LESFAC(NBRFAC)  ='VZ  '
  363. C
  364.                      NBTYPE=1
  365.                      SEGINI NOTYPE
  366.                      MOTYPE=NOTYPE
  367.                      TYPE(1)='REAL*8'
  368.                      CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
  369.      1                                 MOTYPE,1,INFOS,3,IVACAR)
  370.                      SEGSUP NOTYPE
  371.                      IF (IERR.NE.0) GOTO 9990
  372.                   ENDIF
  373.                ENDIF
  374.          ELSE
  375.             MOTERR(1:8)='CARACTER'
  376.             MOTERR(9:12)=NOMTP(NEFMOD)
  377.             MOTERR(13:20)='PRIN    '
  378.             CALL ERREUR(145)
  379.             GOTO 9990
  380.          ENDIF
  381.       ENDIF
  382. C
  383.       NCARA=NBROBL
  384.       NCARF=NBRFAC
  385.       NCARR=NCARA+NCARF
  386.       IF(ISUP2.EQ.1.AND.MOCARA.NE.0)THEN
  387.         CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  388.         IF(IERR.NE.0)THEN
  389.               ISUP2=0
  390.               GOTO 9990
  391.         ENDIF
  392.       ENDIF
  393. C
  394. C=================================================================
  395. C              MASSI COQUE COQEP POUT  CIST  THER  TUYAU LISP
  396.          GOTO (10,66,30,66,50,66,66,66,30,66,66,66,66,66,90),MFR
  397. C Cas particulier des elements InCompressibles (MFR=31)
  398.          IF (MFR.EQ.31) GOTO 10
  399. c        cas Xfem: identique au cas massif
  400.          IF(MFR.EQ.63) goto 10
  401. c
  402. C=================================================================
  403.    66 CONTINUE
  404.       MOTERR(1:8)=NOMFR(MFR)
  405.       CALL ERREUR (194)
  406.       GOTO 9990
  407. C____________________________________________________________________
  408. C
  409. C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
  410. C____________________________________________________________________
  411. C
  412.    10 CONTINUE
  413. C
  414. C     REMPLISSAGE DU SEGMENT CONTENANT LES MATRICES(JACOBIEN)
  415. C
  416.         IF (IDIM.EQ.1) THEN
  417.           DO IB=1,NBELEM
  418.             DO IGAU=1,NBPGAU
  419.               MPTVAL=IVACOM
  420.               MELVAL=IVAL(1)
  421.               IGMN=MIN(IGAU,VELCHE(/1))
  422.               IBMN=MIN(IB  ,VELCHE(/2))
  423.               SIG(1)=VELCHE(IGMN,IBMN)
  424.               MELVAL=IVAL(2)
  425.               IGMN=MIN(IGAU,VELCHE(/1))
  426.               IBMN=MIN(IB  ,VELCHE(/2))
  427.               SIG(2)=VELCHE(IGMN,IBMN)
  428.               MELVAL=IVAL(3)
  429.               IGMN=MIN(IGAU,VELCHE(/1))
  430.               IBMN=MIN(IB  ,VELCHE(/2))
  431.               SIG(3)=VELCHE(IGMN,IBMN)
  432.               CALL ORDO01(SIG(1),3,.FALSE.)
  433.               MPTVAL=IVAPRI
  434.               MELVAL=IVAL(1)
  435.               IGMN=MIN(IGAU,VELCHE(/1))
  436.               IBMN=MIN(IB  ,VELCHE(/2))
  437.               VELCHE(IGMN,IBMN)=SIG(1)
  438.               MELVAL=IVAL(2)
  439.               IGMN=MIN(IGAU,VELCHE(/1))
  440.               IBMN=MIN(IB  ,VELCHE(/2))
  441.               VELCHE(IGMN,IBMN)=SIG(2)
  442.               MELVAL=IVAL(3)
  443.               IGMN=MIN(IGAU,VELCHE(/1))
  444.               IBMN=MIN(IB  ,VELCHE(/2))
  445.               VELCHE(IGMN,IBMN)=SIG(3)
  446.             ENDDO
  447.           ENDDO
  448.           GOTO 110
  449.         ENDIF
  450.  
  451. C     BOUCLE SUR LES ELEMENTS
  452.       DO IB=1,NBELEM
  453. C
  454. C        BOUCLE SUR LES POINTS DE GAUSS
  455. C
  456.          DO IGAU=1,NBPGAU
  457. C
  458.             MPTVAL=IVACOM
  459.  
  460.             MELVAL=IVAL(1)
  461.             IGMN=MIN(IGAU,VELCHE(/1))
  462.             IBMN=MIN(IB  ,VELCHE(/2))
  463.             A(1,1) =  VELCHE(IGMN,IBMN)
  464. C
  465.             MELVAL=IVAL(2)
  466.             IGMN=MIN(IGAU,VELCHE(/1))
  467.             IBMN=MIN(IB  ,VELCHE(/2))
  468.             A(2,2) = VELCHE(IGMN,IBMN)
  469. C
  470.             MELVAL=IVAL(3)
  471.             IGMN=MIN(IGAU,VELCHE(/1))
  472.             IBMN=MIN(IB  ,VELCHE(/2))
  473.             A(3,3) = VELCHE(IGMN,IBMN)
  474. C
  475.             MELVAL=IVAL(4)
  476.             IGMN=MIN(IGAU,VELCHE(/1))
  477.             IBMN=MIN(IB  ,VELCHE(/2))
  478.             A(1,2) = XMULIJ*VELCHE(IGMN,IBMN)
  479.             A(2,1) = A(1,2)
  480. C
  481.             IF(IFOUR.LT.1.AND.IFOUR.GE.-3) THEN
  482.                IF(LETRID.EQ.1) THEN
  483.                   IDIMM = 3
  484.                   A(1,3)=0.
  485.                   A(2,3)=0.
  486.                ENDIF
  487.                GO TO 6610
  488.             ENDIF
  489. C
  490.             IF(IFOUR.EQ.1) IDIMM=3
  491.             MELVAL=IVAL(5)
  492.             IGMN=MIN(IGAU,VELCHE(/1))
  493.             IBMN=MIN(IB  ,VELCHE(/2))
  494.             A(3,1) = XMULIJ*VELCHE(IGMN,IBMN)
  495. C
  496.             MELVAL=IVAL(6)
  497.             IGMN=MIN(IGAU,VELCHE(/1))
  498.             IBMN=MIN(IB  ,VELCHE(/2))
  499.             A(3,2) = XMULIJ*VELCHE(IGMN,IBMN)
  500.             A(1,3) = A(3,1)
  501.             A(2,3) = A(3,2)
  502. C
  503.  6610       CONTINUE
  504. C
  505. C       REMPLISSAGE DU SEGMENT CONTENANT LES VALEURS ET VECTEURS PROPRES
  506. C
  507.             CALL JACOB3(A,IDIMM,D,S)
  508. C
  509.             MPTVAL=IVAPRI
  510. C
  511.             DO 2010 ID = 1,3
  512.                MELVAL=IVAL(ID)
  513.                IGMN=MIN(IGAU,VELCHE(/1))
  514.                IBMN=MIN(IB  ,VELCHE(/2))
  515.                VELCHE(IGMN,IBMN) = D(ID)
  516. C
  517.                MELVAL=IVAL(ID+3)
  518.                IGMN=MIN(IGAU,VELCHE(/1))
  519.                IBMN=MIN(IB  ,VELCHE(/2))
  520.                VELCHE(IGMN,IBMN) = S(ID,1)
  521. C
  522.                MELVAL=IVAL(ID+6)
  523.                IGMN=MIN(IGAU,VELCHE(/1))
  524.                IBMN=MIN(IB  ,VELCHE(/2))
  525.                VELCHE(IGMN,IBMN) = S(ID,2)
  526. C
  527.                MELVAL=IVAL(ID+9)
  528.                IGMN=MIN(IGAU,VELCHE(/1))
  529.                IBMN=MIN(IB  ,VELCHE(/2))
  530.                VELCHE(IGMN,IBMN) = S(ID,3)
  531. C
  532.  2010       CONTINUE
  533. C
  534.         END DO
  535. C
  536.       END DO
  537. C
  538.       GOTO 110
  539.    30 CONTINUE
  540. C____________________________________________________________________
  541. C
  542. C                FORMULATION COQUE
  543. C____________________________________________________________________
  544. C
  545.       SEGINI MWRK1
  546. C
  547. C     BOUCLE SUR LES ELEMENTS
  548.       DO IB=1,NBELEM
  549. C
  550. C     BOUCLE SUR LES POINTS DE GAUSS
  551. C
  552.         DO IGAU=1,NBPGAU
  553. C
  554.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  555.           IF(IDIM.EQ.3) THEN
  556.             CALL VPAST(XEL,BPSS)
  557.           ELSE IF(IDIM.EQ.2) THEN
  558.             CALL VPAST2(XEL,BPSS)
  559.           ENDIF
  560.           CALL TRPOSE(BPSS)
  561. C
  562. C       REMPLISSAGE DU SEGMENT CONTENANT LES CARACTERISTIQUES  ET
  563. C                     CALCUL DES CONTRAINTES
  564. C
  565.             MPTVAL=IVACOM
  566. C
  567.           DO ID = 1,NSTRS
  568.             MELVAL=IVAL(ID)
  569.             IGMN=MIN(IGAU,VELCHE(/1))
  570.             IBMN=MIN(IB  ,VELCHE(/2))
  571.             SIG(ID) =  VELCHE(IGMN,IBMN)
  572.           END DO
  573. C
  574.           MPTVAL=IVACAR
  575. C
  576.           MELVAL=IVAL(1)
  577.           EPAIST =  VELCHE(1,1)
  578. C
  579.           MELVAL=IVAL(2)
  580.           IF (IVAL(2).NE.0) THEN
  581.             EXCEN = VELCHE(1,1)
  582.           ELSE
  583.             EXCEN =REAL(0.D0)
  584.           ENDIF
  585. C
  586. c+mdj
  587.           IF(NPINT.NE.0) THEN
  588.             SIG(4)= SIG(4)*XMULIJ
  589.             CALL PRINC(SIG,V1,NSTRS)
  590.             MPTVAL=IVAPRI
  591.             DO ID = 1,4
  592.               MELVAL=IVAL(ID)
  593.               IGMN=MIN(IGAU,VELCHE(/1))
  594.               IBMN=MIN(IB  ,VELCHE(/2))
  595.               VELCHE(IGMN,IBMN) = V1(ID)
  596.             END DO
  597.             GOTO 1130
  598.           ENDIF
  599. c+mdj
  600. C
  601.           CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  602. C
  603.           IF(IFOUR.GT.0) THEN
  604. C
  605.             A(1,1) = SIG(1) + XFLOT*SIG(4)
  606.             A(2,2) = SIG(2) + XFLOT*SIG(5)
  607.             A(1,2) = XMULIJ*(SIG(3) + XFLOT*SIG(6))
  608.             A(2,1) = A(1,2)
  609.           ELSE   IF(IFOUR.LE.0) THEN
  610.             A(1,1) = SIG(1) + XFLOT*SIG(3)
  611.             A(2,2) = SIG(2) + XFLOT*SIG(4)
  612.             A(1,2) =REAL(0.D0)
  613.             A(2,1) =REAL(0.D0)
  614.           ENDIF
  615. C
  616.           CALL JACOB3(A,2,D,S)
  617.           CALL MULMAT(A,BPSS,S,3,3,3)
  618. C
  619.           MPTVAL=IVAPRI
  620. C
  621.           DO ID = 1,2
  622.             MELVAL=IVAL(ID)
  623.             IGMN=MIN(IGAU,VELCHE(/1))
  624.             IBMN=MIN(IB  ,VELCHE(/2))
  625.             VELCHE(IGMN,IBMN) = D(ID)
  626.           END DO
  627. C
  628.           DO ID = 1,3
  629.             MELVAL=IVAL(ID+2)
  630.             IGMN=MIN(IGAU,VELCHE(/1))
  631.             IBMN=MIN(IB  ,VELCHE(/2))
  632.             VELCHE(IGMN,IBMN)= A(ID,1)
  633. C
  634.             MELVAL=IVAL(ID+5)
  635.             IGMN=MIN(IGAU,VELCHE(/1))
  636.             IBMN=MIN(IB  ,VELCHE(/2))
  637.             VELCHE(IGMN,IBMN)= A(ID,2)
  638.           END DO
  639.  
  640.  1130 CONTINUE
  641.  
  642. C
  643.         END DO
  644. C
  645.       END DO
  646. C
  647.       GOTO 110
  648.   50  CONTINUE
  649. C
  650. C    FORMULATION COQUE  EPAISSE  PLUS COMPLIQUE CAR IL FAUT
  651. C                  RECUPERER LES EPAISSEURS ET LES FCTNS DE FORME
  652. C
  653. C     PETITE HORREUR LOCALE ON SUPPOSE EPAISSEUR CONSTANTE
  654. C
  655.       SEGACT MINTE1
  656.       SEGINI MWRK1,MWRK2
  657.       N1PTEL=NBGS
  658. C
  659.       DO 1052 IB = 1,NBNN
  660.             TH(IB)=UN
  661.  1052 CONTINUE
  662.  
  663. C     BOUCLE SUR LES ELEMENTS
  664.       DO IB=1,NBELEM
  665. C
  666. C     BOUCLE SUR LES POINTS DE GAUSS
  667. C
  668.         DO IGAU=1,NBPGAU
  669.  
  670. C
  671.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  672.           CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
  673. C
  674.           DO IC=1,NBGS
  675.                 E=DZEGAU(IC)
  676. C
  677.           CALL CQ8LC1(IC,NBNN,E,XEL,TH,SHPTOT,TXR,BPSS,IRR)
  678. C
  679.                 MPTVAL=IVACOM
  680. C
  681.                 MELVAL=IVAL(1)
  682.                 IGMN=MIN(IGAU,VELCHE(/1))
  683.                 IBMN=MIN(IB  ,VELCHE(/2))
  684.                 A(1,1) =  VELCHE(IGMN,IBMN)
  685. C
  686.                 MELVAL=IVAL(2)
  687.                 IGMN=MIN(IGAU,VELCHE(/1))
  688.                 IBMN=MIN(IB  ,VELCHE(/2))
  689.                 A(2,2) =  VELCHE(IGMN,IBMN)
  690. C
  691.                 MELVAL=IVAL(3)
  692.                 IGMN=MIN(IGAU,VELCHE(/1))
  693.                 IBMN=MIN(IB  ,VELCHE(/2))
  694.                 A(1,2) =  XMULIJ*VELCHE(IGMN,IBMN)
  695.                 A(2,1) = A(1,2)
  696. C
  697.           CALL JACOB3(A,2,D,S)
  698.           CALL MULMAT(A,BPSS,S,3,3,3)
  699. C
  700.                 MPTVAL=IVAPRI
  701. C
  702.                 MELVAL=IVAL(1)
  703.                 IGMN=MIN(IGAU,VELCHE(/1))
  704.                 IBMN=MIN(IB  ,VELCHE(/2))
  705.                 VELCHE(IGMN,IBMN) = D(1)
  706. C
  707.                 MELVAL=IVAL(2)
  708.                 IGMN=MIN(IGAU,VELCHE(/1))
  709.                 IBMN=MIN(IB  ,VELCHE(/2))
  710.                 VELCHE(IGMN,IBMN)= D(2)
  711. C
  712.               DO ID = 1,3
  713.                 MELVAL=IVAL(ID+2)
  714.                 IGMN=MIN(IGAU,VELCHE(/1))
  715.                 IBMN=MIN(IB  ,VELCHE(/2))
  716.                 VELCHE(IGMN,IBMN)= A(ID,1)
  717. C
  718.                 MELVAL=IVAL(ID+5)
  719.                 IGMN=MIN(IGAU,VELCHE(/1))
  720.                 IBMN=MIN(IB  ,VELCHE(/2))
  721.                 VELCHE(IGMN,IBMN)= A(ID,2)
  722.               END DO
  723. C
  724.            END DO
  725. C
  726.          END DO
  727. C
  728.        END DO
  729. C
  730.       SEGSUP MWRK1,MWRK2
  731. C
  732.       GOTO 110
  733.   90  CONTINUE
  734. C
  735. C     CAS LINESPRING
  736. C
  737. C     BOUCLE SUR LES ELEMENTS
  738.       DO IB=1,NBELEM
  739. C
  740. C     BOUCLE SUR LES POINTS DE GAUSS
  741. C
  742.         DO IGAU=1,NBPGAU
  743.  
  744.           MPTVAL=IVACAR
  745. C
  746.           MELVAL=IVAL(1)
  747.           IGMN=MIN(IGAU,VELCHE(/1))
  748.           IBMN=MIN(IB  ,VELCHE(/2))
  749.           EP  =  VELCHE(IGMN,IBMN)
  750.           EP2 = EP*EP/REAL(6.D0)
  751. C
  752.           MPTVAL=IVACOM
  753. C
  754.           MELVAL=IVAL(1)
  755.           IGMN=MIN(IGAU,VELCHE(/1))
  756.           IBMN=MIN(IB  ,VELCHE(/2))
  757.           AUX1 =  VELCHE(IGMN,IBMN)
  758. C
  759.           MELVAL=IVAL(4)
  760.           IGMN=MIN(IGAU,VELCHE(/1))
  761.           IBMN=MIN(IB  ,VELCHE(/2))
  762.           AUX2 =  VELCHE(IGMN,IBMN)
  763. C
  764.           MPTVAL=IVAPRI
  765. C
  766.           MELVAL=IVAL(1)
  767.           IGMN=MIN(IGAU,VELCHE(/1))
  768.           IBMN=MIN(IB  ,VELCHE(/2))
  769.           VELCHE(IGMN,IBMN)=AUX1/EP  +  XFLOT * AUX2/EP2
  770. C
  771.         END DO
  772. C
  773.       END DO
  774. C
  775.          GOTO 110
  776. C
  777. C____________________________________________________________________
  778. C
  779. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  780. C____________________________________________________________________
  781. C
  782.   110 CONTINUE
  783. C
  784.       IF(ISUP1.EQ.1)THEN
  785.            CALL DTMVAL(IVACOM,3)
  786.       ELSE
  787.           CALL DTMVAL(IVACOM,1)
  788.       ENDIF
  789. C
  790.       IF(ISUP2.EQ.1)THEN
  791.            CALL DTMVAL(IVACAR,3)
  792.       ELSE
  793.           CALL DTMVAL(IVACAR,1)
  794.       ENDIF
  795. C
  796.        CALL DTMVAL(IVAPRI,1)
  797. C
  798.       NOMID=MOCARA
  799.       IF (MOCARA.NE.0) SEGSUP NOMID
  800.       NOMID=MOCOMP
  801.       if(lsupno)SEGSUP NOMID
  802.       NOMID=MOSPRI
  803.       if(lsuppr)SEGSUP NOMID
  804. C
  805.   500 CONTINUE
  806. C
  807.       IRET = 1
  808.       RETURN
  809. C
  810. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  811. C
  812.  9990 CONTINUE
  813.       IRET = 0
  814. C
  815.       IF(ISUP1.EQ.1)THEN
  816.            CALL DTMVAL(IVACOM,3)
  817.       ELSE
  818.           CALL DTMVAL(IVACOM,1)
  819.       ENDIF
  820. C
  821.       IF(ISUP2.EQ.1)THEN
  822.            CALL DTMVAL(IVACAR,3)
  823.       ELSE
  824.           CALL DTMVAL(IVACAR,1)
  825.       ENDIF
  826. C
  827.        CALL DTMVAL(IVAPRI,3)
  828. C
  829.       NOMID=MOCARA
  830.       IF (MOCARA.NE.0) SEGSUP NOMID
  831.       NOMID=MOCOMP
  832.       if(lsupno)SEGSUP NOMID
  833.       NOMID=MOSPRI
  834.       if(lsuppr)SEGSUP NOMID
  835.  
  836.       SEGSUP MCHAML
  837.  
  838.       SEGSUP MCHELM
  839.  
  840.       END
  841.  
  842.  
  843.  
  844.  
  845.  
  846.  
  847.  
  848.  

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