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

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