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  25/02/21    21:18:12     12166          
  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. C         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  177. C         IF (IERR.NE.0) THEN
  178. C           SEGSUP MCHELM
  179. C           RETURN
  180. C         ENDIF
  181. C         INFO=IPINF
  182.          MFR  =INFELE(13)
  183.          NBGS =INFELE(4)
  184.          NSTRS=INFELE(16)
  185. C         MINTE=INFELE(11)
  186.          MINTE=INFMOD(7)
  187.          IPMINT=MINTE
  188.          MINTE1=INFMOD(8)
  189. C         SEGSUP,INFO
  190. C
  191. C        CREATION DU TABLEAU INFOS
  192. C
  193.          CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  194.          IF (IRTD.EQ.0) GOTO 9990
  195. C
  196.          INFCHE(ISOUS,1)=0
  197.          INFCHE(ISOUS,2)=0
  198.          INFCHE(ISOUS,3)=NHRM
  199.          INFCHE(ISOUS,4)=MINTE
  200.          INFCHE(ISOUS,5)=0
  201.          INFCHE(ISOUS,6)=5
  202. C
  203. C        INITIALISATION DE MINTE
  204. C
  205.          SEGACT MINTE
  206.          NBPGAU=POIGAU(/1)
  207. C
  208. C        ACTIVATION DU MELEME
  209. C
  210.          SEGACT MELEME
  211.          NBNN  =NUM(/1)
  212.          NBELEM=NUM(/2)
  213.          IPPORE=0
  214.          IF(MFR.EQ.33) IPPORE=NBNN
  215.  
  216. C____________________________________________________________________
  217. C
  218. C        RECHERCHE DES NOMS DE COMPOSANTES
  219. C____________________________________________________________________
  220. C
  221.          lsupno=.false.
  222.          IF(ICONT.EQ.1) THEN
  223.           if(lnomid(4).ne.0) then
  224.              nomid=lnomid(4)
  225.              segact nomid
  226.              mocomp=nomid
  227.              ncomp=lesobl(/2)
  228.              nfac=lesfac(/2)
  229.            else
  230.             lsupno=.true.
  231.             CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  232.            endif
  233.          ELSE IF(IDEFO.EQ.1) THEN
  234.            if(lnomid(5).ne.0) then
  235.              nomid=lnomid(5)
  236.              segact nomid
  237.              ncomp=lesobl(/2)
  238.              mocomp=nomid
  239.             else
  240.              lsupno=.true.
  241.              CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  242.             endif
  243.          ENDIF
  244. C
  245.         if(lnomid(9).ne.0) then
  246.           nomid=lnomid(9)
  247.           segact nomid
  248.           mospri=nomid
  249.           nprin=lesobl(/2)
  250.           nfac=lesfac(/2)
  251.           lsuppr=.false.
  252.         else
  253.           lsuppr=.true.
  254.          CALL IDPRIN(MFR,IFOUR,MOSPRI,NPRIN,NFAC)
  255.         endif
  256. C
  257. C____________________________________________________________________
  258. C
  259. C        VERIFICATION DE LEUR PRESENCE
  260. C____________________________________________________________________
  261. C
  262.          NBTYPE=1
  263.          SEGINI NOTYPE
  264.          MOTYPE=NOTYPE
  265.          TYPE(1)='REAL*8'
  266.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
  267.      1                          MOTYPE,1,INFOS,3,IVACOM)
  268.          SEGSUP NOTYPE
  269.          IF (IERR.NE.0) GOTO 9990
  270.          IF (ISUP1.EQ.1) THEN
  271.            CALL VALCHE(IVACOM,NCOMP,IPMINT,IPPORE,MOCOMP,MELE)
  272.          ENDIF
  273. C
  274. C        RECHERCHE DE LA TAILLE DES MELVAL DES CONTRAINTES
  275. C
  276.          N1PTEL=0
  277.          N1EL=0
  278.          MPTVAL=IVACOM
  279.          DO 111 IO=1,NCOMP
  280.            MELVAL=IVAL(IO)
  281.            N1PTEL=MAX(N1PTEL,VELCHE(/1))
  282.  111     CONTINUE
  283.          NBGCOM=N1PTEL
  284. C
  285.          N1EL=NBELEM
  286. C
  287. C        CREATION DU MCHAML DE LA SOUS ZONE
  288. C
  289.          N2=NPRIN
  290.          SEGINI MCHAML
  291.          ICHAML(ISOUS)=MCHAML
  292.          NSR=1
  293.          NCOSOR=NPRIN
  294.          SEGINI MPTVAL
  295.          IVAPRI=MPTVAL
  296.          NOMID=MOSPRI
  297.          SEGACT NOMID
  298.          DO 100 ICOMP=1,NPRIN
  299.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  300.             TYPCHE(ICOMP)='REAL*8'
  301.             N2PTEL=0
  302.             N2EL=0
  303.             SEGINI MELVAL
  304.             IELVAL(ICOMP)=MELVAL
  305.             IVAL(ICOMP)=MELVAL
  306.  100     CONTINUE
  307. C____________________________________________________________________
  308. C
  309. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES                   *
  310. C____________________________________________________________________
  311. C
  312.          NBROBL=0
  313.          NBRFAC=0
  314.          MOCARA=0
  315. C
  316. C EPAISSEUR ET EXCENTREMENT DANS LE CAS DES COQUES
  317. C
  318.          IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9) THEN
  319.             NBROBL=1
  320.             NBRFAC=1
  321.             SEGINI NOMID
  322.             MOCARA=NOMID
  323.             LESOBL(1)='EPAI'
  324.             LESFAC(1)='EXCE'
  325. C
  326. C CARACTERISTIQUES POUR LES LINESPRING
  327. C
  328.          ELSE IF (MFR.EQ.15) THEN
  329.             NBROBL=1
  330.             SEGINI NOMID
  331.             MOCARA=NOMID
  332.             LESOBL(1)='EPAI'
  333.          ENDIF
  334. C
  335.       IF (MOCARA.NE.0) THEN
  336.          IF (IPCHE2.NE.0) THEN
  337.             NBTYPE=1
  338.             SEGINI NOTYPE
  339.             MOTYPE=NOTYPE
  340.             TYPE(1)='REAL*8'
  341.             CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
  342.      1                          MOTYPE,1,INFOS,3,IVACAR)
  343.             SEGSUP NOTYPE
  344.             IF (IERR.NE.0) GOTO 9990
  345.                IF (IVECT.EQ.1) THEN
  346.                   MPTVAL=IVACAR
  347.                   IF (IVAL(NBROBL+NBRFAC).EQ.0) THEN
  348. C
  349. C                    MOT CLE VECT EN CAS DE CONVERSION
  350. C
  351.                      IVECT=2
  352.                      NOMID=MOCARA
  353.                      SEGACT NOMID
  354.                      NBRFAC=NBRFAC+2
  355.                      SEGADJ NOMID
  356.                      MOCARA=NOMID
  357.                      LESFAC(NBRFAC-2)='VX  '
  358.                      LESFAC(NBRFAC-1)='VY  '
  359.                      LESFAC(NBRFAC)  ='VZ  '
  360. C
  361.                      NBTYPE=1
  362.                      SEGINI NOTYPE
  363.                      MOTYPE=NOTYPE
  364.                      TYPE(1)='REAL*8'
  365.                      CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,
  366.      1                                 MOTYPE,1,INFOS,3,IVACAR)
  367.                      SEGSUP NOTYPE
  368.                      IF (IERR.NE.0) GOTO 9990
  369.                   ENDIF
  370.                ENDIF
  371.          ELSE
  372.             MOTERR(1:8)='CARACTER'
  373.             MOTERR(9:12)=NOMTP(NEFMOD)
  374.             MOTERR(13:20)='PRIN    '
  375.             CALL ERREUR(145)
  376.             GOTO 9990
  377.          ENDIF
  378.       ENDIF
  379. C
  380.       NCARA=NBROBL
  381.       NCARF=NBRFAC
  382.       NCARR=NCARA+NCARF
  383.       IF(ISUP2.EQ.1.AND.MOCARA.NE.0)THEN
  384.         CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE,MOCARA,MELE)
  385.         IF(IERR.NE.0)THEN
  386.               ISUP2=0
  387.               GOTO 9990
  388.         ENDIF
  389.       ENDIF
  390. C
  391. C=================================================================
  392. C              MASSI COQUE COQEP POUT  CIST  THER  TUYAU LISP
  393.          GOTO (10,66,30,66,50,66,66,66,30,66,66,66,66,66,90),MFR
  394. C Cas particulier des elements InCompressibles (MFR=31)
  395.          IF (MFR.EQ.31) GOTO 10
  396. c        cas Xfem: identique au cas massif
  397.          IF(MFR.EQ.63) goto 10
  398. c
  399. C=================================================================
  400.    66 CONTINUE
  401.       MOTERR(1:8)=NOMFR(MFR)
  402.       CALL ERREUR (194)
  403.       GOTO 9990
  404. C____________________________________________________________________
  405. C
  406. C     SECTEUR DE CALCUL POUR LES ELEMENTS MASSIFS
  407. C____________________________________________________________________
  408. C
  409.    10 CONTINUE
  410. C
  411. C     REMPLISSAGE DU SEGMENT CONTENANT LES MATRICES(JACOBIEN)
  412. C
  413.         IF (IDIM.EQ.1) THEN
  414.           DO IB=1,NBELEM
  415.             DO IGAU=1,NBPGAU
  416.               MPTVAL=IVACOM
  417.               MELVAL=IVAL(1)
  418.               IGMN=MIN(IGAU,VELCHE(/1))
  419.               IBMN=MIN(IB  ,VELCHE(/2))
  420.               SIG(1)=VELCHE(IGMN,IBMN)
  421.               MELVAL=IVAL(2)
  422.               IGMN=MIN(IGAU,VELCHE(/1))
  423.               IBMN=MIN(IB  ,VELCHE(/2))
  424.               SIG(2)=VELCHE(IGMN,IBMN)
  425.               MELVAL=IVAL(3)
  426.               IGMN=MIN(IGAU,VELCHE(/1))
  427.               IBMN=MIN(IB  ,VELCHE(/2))
  428.               SIG(3)=VELCHE(IGMN,IBMN)
  429.               CALL ORDO01(SIG(1),3,.FALSE.)
  430.               MPTVAL=IVAPRI
  431.               MELVAL=IVAL(1)
  432.               IGMN=MIN(IGAU,VELCHE(/1))
  433.               IBMN=MIN(IB  ,VELCHE(/2))
  434.               VELCHE(IGMN,IBMN)=SIG(1)
  435.               MELVAL=IVAL(2)
  436.               IGMN=MIN(IGAU,VELCHE(/1))
  437.               IBMN=MIN(IB  ,VELCHE(/2))
  438.               VELCHE(IGMN,IBMN)=SIG(2)
  439.               MELVAL=IVAL(3)
  440.               IGMN=MIN(IGAU,VELCHE(/1))
  441.               IBMN=MIN(IB  ,VELCHE(/2))
  442.               VELCHE(IGMN,IBMN)=SIG(3)
  443.             ENDDO
  444.           ENDDO
  445.           GOTO 110
  446.         ENDIF
  447.  
  448. C     BOUCLE SUR LES ELEMENTS
  449.       DO IB=1,NBELEM
  450. C
  451. C        BOUCLE SUR LES POINTS DE GAUSS
  452. C
  453.          DO IGAU=1,NBPGAU
  454. C
  455.             MPTVAL=IVACOM
  456.  
  457.             MELVAL=IVAL(1)
  458.             IGMN=MIN(IGAU,VELCHE(/1))
  459.             IBMN=MIN(IB  ,VELCHE(/2))
  460.             A(1,1) =  VELCHE(IGMN,IBMN)
  461. C
  462.             MELVAL=IVAL(2)
  463.             IGMN=MIN(IGAU,VELCHE(/1))
  464.             IBMN=MIN(IB  ,VELCHE(/2))
  465.             A(2,2) = VELCHE(IGMN,IBMN)
  466. C
  467.             MELVAL=IVAL(3)
  468.             IGMN=MIN(IGAU,VELCHE(/1))
  469.             IBMN=MIN(IB  ,VELCHE(/2))
  470.             A(3,3) = VELCHE(IGMN,IBMN)
  471. C
  472.             MELVAL=IVAL(4)
  473.             IGMN=MIN(IGAU,VELCHE(/1))
  474.             IBMN=MIN(IB  ,VELCHE(/2))
  475.             A(1,2) = XMULIJ*VELCHE(IGMN,IBMN)
  476.             A(2,1) = A(1,2)
  477. C
  478.             IF(IFOUR.LT.1.AND.IFOUR.GE.-3) THEN
  479.                IF(LETRID.EQ.1) THEN
  480.                   IDIMM = 3
  481.                   A(1,3)=0.
  482.                   A(2,3)=0.
  483.                ENDIF
  484.                GO TO 6610
  485.             ENDIF
  486. C
  487.             IF(IFOUR.EQ.1) IDIMM=3
  488.             MELVAL=IVAL(5)
  489.             IGMN=MIN(IGAU,VELCHE(/1))
  490.             IBMN=MIN(IB  ,VELCHE(/2))
  491.             A(3,1) = XMULIJ*VELCHE(IGMN,IBMN)
  492. C
  493.             MELVAL=IVAL(6)
  494.             IGMN=MIN(IGAU,VELCHE(/1))
  495.             IBMN=MIN(IB  ,VELCHE(/2))
  496.             A(3,2) = XMULIJ*VELCHE(IGMN,IBMN)
  497.             A(1,3) = A(3,1)
  498.             A(2,3) = A(3,2)
  499. C
  500.  6610       CONTINUE
  501. C
  502. C       REMPLISSAGE DU SEGMENT CONTENANT LES VALEURS ET VECTEURS PROPRES
  503. C
  504.             CALL JACOB3(A,IDIMM,D,S)
  505. C
  506.             MPTVAL=IVAPRI
  507. C
  508.             DO 2010 ID = 1,3
  509.                MELVAL=IVAL(ID)
  510.                IGMN=MIN(IGAU,VELCHE(/1))
  511.                IBMN=MIN(IB  ,VELCHE(/2))
  512.                VELCHE(IGMN,IBMN) = D(ID)
  513. C
  514.                MELVAL=IVAL(ID+3)
  515.                IGMN=MIN(IGAU,VELCHE(/1))
  516.                IBMN=MIN(IB  ,VELCHE(/2))
  517.                VELCHE(IGMN,IBMN) = S(ID,1)
  518. C
  519.                MELVAL=IVAL(ID+6)
  520.                IGMN=MIN(IGAU,VELCHE(/1))
  521.                IBMN=MIN(IB  ,VELCHE(/2))
  522.                VELCHE(IGMN,IBMN) = S(ID,2)
  523. C
  524.                MELVAL=IVAL(ID+9)
  525.                IGMN=MIN(IGAU,VELCHE(/1))
  526.                IBMN=MIN(IB  ,VELCHE(/2))
  527.                VELCHE(IGMN,IBMN) = S(ID,3)
  528. C
  529.  2010       CONTINUE
  530. C
  531.         END DO
  532. C
  533.       END DO
  534. C
  535.       GOTO 110
  536.    30 CONTINUE
  537. C____________________________________________________________________
  538. C
  539. C                FORMULATION COQUE
  540. C____________________________________________________________________
  541. C
  542.       SEGINI MWRK1
  543. C
  544. C     BOUCLE SUR LES ELEMENTS
  545.       DO IB=1,NBELEM
  546. C
  547. C     BOUCLE SUR LES POINTS DE GAUSS
  548. C
  549.         DO IGAU=1,NBPGAU
  550. C
  551.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  552.           IF(IDIM.EQ.3) THEN
  553.             CALL VPAST(XEL,BPSS)
  554.           ELSE IF(IDIM.EQ.2) THEN
  555.             CALL VPAST2(XEL,BPSS)
  556.           ENDIF
  557.           CALL TRPOSE(BPSS)
  558. C
  559. C       REMPLISSAGE DU SEGMENT CONTENANT LES CARACTERISTIQUES  ET
  560. C                     CALCUL DES CONTRAINTES
  561. C
  562.             MPTVAL=IVACOM
  563. C
  564.           DO ID = 1,NSTRS
  565.             MELVAL=IVAL(ID)
  566.             IGMN=MIN(IGAU,VELCHE(/1))
  567.             IBMN=MIN(IB  ,VELCHE(/2))
  568.             SIG(ID) =  VELCHE(IGMN,IBMN)
  569.           END DO
  570. C
  571.           MPTVAL=IVACAR
  572. C
  573.           MELVAL=IVAL(1)
  574.           EPAIST =  VELCHE(1,1)
  575. C
  576.           MELVAL=IVAL(2)
  577.           IF (IVAL(2).NE.0) THEN
  578.             EXCEN = VELCHE(1,1)
  579.           ELSE
  580.             EXCEN =REAL(0.D0)
  581.           ENDIF
  582. C
  583. c+mdj
  584.           IF(NPINT.NE.0) THEN
  585.             SIG(4)= SIG(4)*XMULIJ
  586.             CALL PRINC(SIG,V1,NSTRS)
  587.             MPTVAL=IVAPRI
  588.             DO ID = 1,4
  589.               MELVAL=IVAL(ID)
  590.               IGMN=MIN(IGAU,VELCHE(/1))
  591.               IBMN=MIN(IB  ,VELCHE(/2))
  592.               VELCHE(IGMN,IBMN) = V1(ID)
  593.             END DO
  594.             GOTO 1130
  595.           ENDIF
  596. c+mdj
  597. C
  598.           CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  599. C
  600.           IF(IFOUR.GT.0) THEN
  601. C
  602.             A(1,1) = SIG(1) + XFLOT*SIG(4)
  603.             A(2,2) = SIG(2) + XFLOT*SIG(5)
  604.             A(1,2) = XMULIJ*(SIG(3) + XFLOT*SIG(6))
  605.             A(2,1) = A(1,2)
  606.           ELSE   IF(IFOUR.LE.0) THEN
  607.             A(1,1) = SIG(1) + XFLOT*SIG(3)
  608.             A(2,2) = SIG(2) + XFLOT*SIG(4)
  609.             A(1,2) =REAL(0.D0)
  610.             A(2,1) =REAL(0.D0)
  611.           ENDIF
  612. C
  613.           CALL JACOB3(A,2,D,S)
  614.           CALL MULMAT(A,BPSS,S,3,3,3)
  615. C
  616.           MPTVAL=IVAPRI
  617. C
  618.           DO ID = 1,2
  619.             MELVAL=IVAL(ID)
  620.             IGMN=MIN(IGAU,VELCHE(/1))
  621.             IBMN=MIN(IB  ,VELCHE(/2))
  622.             VELCHE(IGMN,IBMN) = D(ID)
  623.           END DO
  624. C
  625.           DO ID = 1,3
  626.             MELVAL=IVAL(ID+2)
  627.             IGMN=MIN(IGAU,VELCHE(/1))
  628.             IBMN=MIN(IB  ,VELCHE(/2))
  629.             VELCHE(IGMN,IBMN)= A(ID,1)
  630. C
  631.             MELVAL=IVAL(ID+5)
  632.             IGMN=MIN(IGAU,VELCHE(/1))
  633.             IBMN=MIN(IB  ,VELCHE(/2))
  634.             VELCHE(IGMN,IBMN)= A(ID,2)
  635.           END DO
  636.  
  637.  1130 CONTINUE
  638.  
  639. C
  640.         END DO
  641. C
  642.       END DO
  643. C
  644.       GOTO 110
  645.   50  CONTINUE
  646. C
  647. C    FORMULATION COQUE  EPAISSE  PLUS COMPLIQUE CAR IL FAUT
  648. C                  RECUPERER LES EPAISSEURS ET LES FCTNS DE FORME
  649. C
  650. C     PETITE HORREUR LOCALE ON SUPPOSE EPAISSEUR CONSTANTE
  651. C
  652.       SEGACT MINTE1
  653.       SEGINI MWRK1,MWRK2
  654.       N1PTEL=NBGS
  655. C
  656.       DO 1052 IB = 1,NBNN
  657.             TH(IB)=UN
  658.  1052 CONTINUE
  659.  
  660. C     BOUCLE SUR LES ELEMENTS
  661.       DO IB=1,NBELEM
  662. C
  663. C     BOUCLE SUR LES POINTS DE GAUSS
  664. C
  665.         DO IGAU=1,NBPGAU
  666.  
  667. C
  668.           CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XEL)
  669.           CALL CQ8LOC(XEL,NBNN,MINTE1.SHPTOT,TXR,IRR)
  670. C
  671.           DO IC=1,NBGS
  672.                 E=DZEGAU(IC)
  673. C
  674.           CALL CQ8LC1(IC,NBNN,E,XEL,TH,SHPTOT,TXR,BPSS,IRR)
  675. C
  676.                 MPTVAL=IVACOM
  677. C
  678.                 MELVAL=IVAL(1)
  679.                 IGMN=MIN(IGAU,VELCHE(/1))
  680.                 IBMN=MIN(IB  ,VELCHE(/2))
  681.                 A(1,1) =  VELCHE(IGMN,IBMN)
  682. C
  683.                 MELVAL=IVAL(2)
  684.                 IGMN=MIN(IGAU,VELCHE(/1))
  685.                 IBMN=MIN(IB  ,VELCHE(/2))
  686.                 A(2,2) =  VELCHE(IGMN,IBMN)
  687. C
  688.                 MELVAL=IVAL(3)
  689.                 IGMN=MIN(IGAU,VELCHE(/1))
  690.                 IBMN=MIN(IB  ,VELCHE(/2))
  691.                 A(1,2) =  XMULIJ*VELCHE(IGMN,IBMN)
  692.                 A(2,1) = A(1,2)
  693. C
  694.           CALL JACOB3(A,2,D,S)
  695.           CALL MULMAT(A,BPSS,S,3,3,3)
  696. C
  697.                 MPTVAL=IVAPRI
  698. C
  699.                 MELVAL=IVAL(1)
  700.                 IGMN=MIN(IGAU,VELCHE(/1))
  701.                 IBMN=MIN(IB  ,VELCHE(/2))
  702.                 VELCHE(IGMN,IBMN) = D(1)
  703. C
  704.                 MELVAL=IVAL(2)
  705.                 IGMN=MIN(IGAU,VELCHE(/1))
  706.                 IBMN=MIN(IB  ,VELCHE(/2))
  707.                 VELCHE(IGMN,IBMN)= D(2)
  708. C
  709.               DO ID = 1,3
  710.                 MELVAL=IVAL(ID+2)
  711.                 IGMN=MIN(IGAU,VELCHE(/1))
  712.                 IBMN=MIN(IB  ,VELCHE(/2))
  713.                 VELCHE(IGMN,IBMN)= A(ID,1)
  714. C
  715.                 MELVAL=IVAL(ID+5)
  716.                 IGMN=MIN(IGAU,VELCHE(/1))
  717.                 IBMN=MIN(IB  ,VELCHE(/2))
  718.                 VELCHE(IGMN,IBMN)= A(ID,2)
  719.               END DO
  720. C
  721.            END DO
  722. C
  723.          END DO
  724. C
  725.        END DO
  726. C
  727.       SEGSUP MWRK1,MWRK2
  728. C
  729.       GOTO 110
  730.   90  CONTINUE
  731. C
  732. C     CAS LINESPRING
  733. C
  734. C     BOUCLE SUR LES ELEMENTS
  735.       DO IB=1,NBELEM
  736. C
  737. C     BOUCLE SUR LES POINTS DE GAUSS
  738. C
  739.         DO IGAU=1,NBPGAU
  740.  
  741.           MPTVAL=IVACAR
  742. C
  743.           MELVAL=IVAL(1)
  744.           IGMN=MIN(IGAU,VELCHE(/1))
  745.           IBMN=MIN(IB  ,VELCHE(/2))
  746.           EP  =  VELCHE(IGMN,IBMN)
  747.           EP2 = EP*EP/REAL(6.D0)
  748. C
  749.           MPTVAL=IVACOM
  750. C
  751.           MELVAL=IVAL(1)
  752.           IGMN=MIN(IGAU,VELCHE(/1))
  753.           IBMN=MIN(IB  ,VELCHE(/2))
  754.           AUX1 =  VELCHE(IGMN,IBMN)
  755. C
  756.           MELVAL=IVAL(4)
  757.           IGMN=MIN(IGAU,VELCHE(/1))
  758.           IBMN=MIN(IB  ,VELCHE(/2))
  759.           AUX2 =  VELCHE(IGMN,IBMN)
  760. C
  761.           MPTVAL=IVAPRI
  762. C
  763.           MELVAL=IVAL(1)
  764.           IGMN=MIN(IGAU,VELCHE(/1))
  765.           IBMN=MIN(IB  ,VELCHE(/2))
  766.           VELCHE(IGMN,IBMN)=AUX1/EP  +  XFLOT * AUX2/EP2
  767. C
  768.         END DO
  769. C
  770.       END DO
  771. C
  772.          GOTO 110
  773. C
  774. C____________________________________________________________________
  775. C
  776. C     DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  777. C____________________________________________________________________
  778. C
  779.   110 CONTINUE
  780. C
  781.       IF(ISUP1.EQ.1)THEN
  782.            CALL DTMVAL(IVACOM,3)
  783.       ELSE
  784.           CALL DTMVAL(IVACOM,1)
  785.       ENDIF
  786. C
  787.       IF(ISUP2.EQ.1)THEN
  788.            CALL DTMVAL(IVACAR,3)
  789.       ELSE
  790.           CALL DTMVAL(IVACAR,1)
  791.       ENDIF
  792. C
  793.        CALL DTMVAL(IVAPRI,1)
  794. C
  795.       NOMID=MOCARA
  796.       IF (MOCARA.NE.0) SEGSUP NOMID
  797.       NOMID=MOCOMP
  798.       if(lsupno)SEGSUP NOMID
  799.       NOMID=MOSPRI
  800.       if(lsuppr)SEGSUP NOMID
  801. C
  802.   500 CONTINUE
  803. C
  804.       IRET = 1
  805.       RETURN
  806. C
  807. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  808. C
  809.  9990 CONTINUE
  810.       IRET = 0
  811. C
  812.       IF(ISUP1.EQ.1)THEN
  813.            CALL DTMVAL(IVACOM,3)
  814.       ELSE
  815.           CALL DTMVAL(IVACOM,1)
  816.       ENDIF
  817. C
  818.       IF(ISUP2.EQ.1)THEN
  819.            CALL DTMVAL(IVACAR,3)
  820.       ELSE
  821.           CALL DTMVAL(IVACAR,1)
  822.       ENDIF
  823. C
  824.        CALL DTMVAL(IVAPRI,3)
  825. C
  826.       NOMID=MOCARA
  827.       IF (MOCARA.NE.0) SEGSUP NOMID
  828.       NOMID=MOCOMP
  829.       if(lsupno)SEGSUP NOMID
  830.       NOMID=MOSPRI
  831.       if(lsuppr)SEGSUP NOMID
  832.  
  833.       SEGSUP MCHAML
  834.  
  835.       SEGSUP MCHELM
  836.  
  837.       RETURN
  838.       END
  839.  
  840.  
  841.  

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