Télécharger la plaquette Cast3M


fr en

Télécharger jacopo.eso

Retour à la liste

Numérotation des lignes : 

jacopo

  1. C JACOPO    SOURCE    PV090527  25/04/01    21:15:03     12222          
  2.  
  3. C=======================================================================
  4. C    ENTREES :
  5. C    ---------
  6. C      IPMODL= pointeur sur un MMODEL
  7. C
  8. C    SORTIES :
  9. C    --------
  10. C
  11. C      IPCHE = CHAMELEM contenant les JACOBIENS
  12. C      IRET  = 1 si succes 0 sinon
  13. C
  14. C    Passage au nouveau Chamelem PAR S.RAMAHANDRY le 11/09/90
  15. C    CB215821 20/03/2017 : Ajout de la formulation DIFFUSION (MFR=73)
  16. C=====================================================================
  17.       SUBROUTINE JACOPO(IPMODL,IPCHE,IRET)
  18.  
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8(A-H,O-Z)
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC CCHAMP
  25.  
  26. -INC SMCHAML
  27. -INC SMMODEL
  28. -INC SMELEME
  29. -INC SMCOORD
  30. -INC SMINTE
  31.  
  32. -INC TMPTVAL
  33.  
  34.       SEGMENT TRA
  35.         REAL*8 XEL(3,NBNN),SHP(6,NBNN),XE(3,NBNN),BPSS(3,3)
  36.       ENDSEGMENT
  37. C
  38.       SEGMENT TR1
  39.         REAL*8 TH(NBN1),TXR(3,3,NBN1),XJ(3,3)
  40.       ENDSEGMENT
  41. C
  42.       SEGMENT INFO
  43.         INTEGER INFELL(JG)
  44.       ENDSEGMENT
  45.  
  46.       PARAMETER(UN=1.D0,XZER=0.D0)
  47.  
  48.       DIMENSION BPSS(3,3)
  49.       CHARACTER*8 CMATE
  50. C
  51.       SEGACT,MCOORD*NOMOD
  52.  
  53.       NHRM  = NIFOUR
  54.       IRET  = 1
  55. C
  56. C     ACTIVATION DU MODELE
  57. C
  58.       MMODEL= IPMODL
  59.       NSOUS = KMODEL(/1)
  60. C
  61. C     CREATION DU MCHELM
  62. C
  63.       N1= NSOUS
  64.       L1= 8
  65.       N3= 6
  66.       SEGINI,MCHELM
  67.       IPCHE =MCHELM
  68.       TITCHE='SCALAIRE'
  69.       IFOCHE=IFOUR
  70. C____________________________________________________________________
  71. C
  72. C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES
  73. C____________________________________________________________________
  74. C
  75.       DO 500 ISOUS=1,NSOUS
  76. C
  77. C     ON RECUPERE L INFORMATION GENERALE
  78. C
  79.       IMODEL=KMODEL(ISOUS)
  80.       IPMAIL=IMAMOD
  81.       IMACHE(ISOUS)=IPMAIL
  82.       CONCHE(ISOUS)=CONMOD
  83. C
  84. C     TRAITEMENT DU MODELE
  85. C
  86.       MELE  = NEFMOD
  87.       MELEME= IMAMOD
  88. C____________________________________________________________________
  89. C
  90. C     INFORMATION SUR L'ELEMENT FINI
  91. C____________________________________________________________________
  92. C
  93.       if(infmod(/1).lt.7) then
  94.         CALL ELQUOI(MELE,0,5,IPINF,IMODEL)
  95.         IF (IERR.NE.0) THEN
  96.           SEGSUP,MCHELM
  97.           IRET=0
  98.           RETURN
  99.         ENDIF
  100.  
  101.         INFO=IPINF
  102.         MELE  = INFELL(1)
  103.         MFR   = INFELL(13)
  104.         MINTE = INFELL(11)
  105.         MINTE1= INFELL(12)
  106.         segsup,info
  107.       else
  108.         MELE =INFELE(1)
  109.         MFR  =INFELE(13)
  110.         MINTE=INFMOD(7)
  111.         MINTE1=INFMOD(8)
  112.       endif
  113. C
  114.       INFCHE(ISOUS,1)= 0
  115.       INFCHE(ISOUS,2)= 0
  116.       INFCHE(ISOUS,3)= NHRM
  117.       INFCHE(ISOUS,4)= MINTE
  118.       INFCHE(ISOUS,5)= 0
  119.       INFCHE(ISOUS,6)= 5
  120. C
  121. C     INITIALISATION DE MINTE
  122. C
  123.         NBPGAU=POIGAU(/1)
  124. C
  125. C     ACTIVATION DU MELEME
  126. C
  127.         NBNN  =NUM(/1)
  128.         NBELEM=NUM(/2)
  129. C
  130. C     RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  131. C
  132.       N1PTEL=NBPGAU
  133.       N1EL=NBELEM
  134. C
  135. C     CREATION DU MCHAML DE LA SOUS ZONE
  136. C
  137.       NJAC=1
  138.       N2  =1
  139.       SEGINI,MCHAML
  140.       ICHAML(ISOUS)=MCHAML
  141.       NSR=1
  142.       NCOSOR=NJAC
  143.       SEGINI MPTVAL
  144.       IVAJAC=MPTVAL
  145. C
  146. C     1 COMPOSANTE
  147. C
  148.       ICOMP        = 1
  149.       NOMCHE(ICOMP)='SCAL '
  150.       TYPCHE(ICOMP)='REAL*8'
  151.       N2PTEL       = 0
  152.       N2EL         = 0
  153.       SEGINI,MELVAL
  154.       IELVAL(ICOMP)= MELVAL
  155.       IVAL(ICOMP)  = MELVAL
  156. C
  157. C     ERREUR FORMULATION INDISPONIBLE
  158. C
  159.       IF(MFR.EQ.1.OR.MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9.OR.MFR.EQ.7
  160.      > .OR.MFR.EQ.13.OR.MFR.EQ.33.OR.MFR.EQ.35.OR.MFR.EQ.49
  161.      > .OR.MFR.EQ.73)
  162.      1   GOTO 44
  163.       MOTERR(1:8)=NOMFR(MFR)
  164.       CALL ERREUR(193)
  165.       IRET=0
  166.       GOTO 9990
  167. C
  168.   44  CONTINUE
  169.  
  170.       SEGINI,TRA
  171. C
  172. C ================== FORMULATION JOINT =======================
  173. C
  174. C ----------------- Element JOT3
  175. C
  176.       IF(MFR.EQ.35) THEN
  177.         IF(MELE.EQ.87) THEN
  178.          DO 9000 IB=1,NBELEM
  179.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  180.             DO 9002 IC=1,NBPGAU
  181.               DO      ID=1,6
  182.               DO      IE=1,NBNN
  183.                  SHP(ID,IE)=SHPTOT(ID,IE,IC)
  184.               ENDDO     
  185.               ENDDO     
  186.  
  187.               CALL JT3LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  188.               IF (NOQUAL.EQ.1) THEN
  189.                 INTERR(1)=IB
  190.                 MOTERR(1:4)='JOT3'
  191.                 CALL ERREUR(765)
  192.                 RETURN
  193.               ELSE IF(NOQUAL.EQ.2) THEN
  194.                 INTERR(1)=IB
  195.                 MOTERR(1:4)='JOT3'
  196.                 CALL ERREUR(766)
  197.                 RETURN
  198.               ENDIF
  199.  
  200.               NBNONN=NBNN/2
  201.            CALL DEVOLU(XEL,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC)
  202.               IRRT = 0
  203.               IF (DJAC.LT.XZER) THEN
  204.                 IRRT = 1
  205.               ELSE IF(DJAC.EQ.XZER) THEN
  206.                 IRRT = 2
  207.               ENDIF
  208.               IF(IRRT.NE.0) THEN
  209.                  CALL ERREUR(764)
  210.                  RETURN
  211.               ENDIF
  212.  
  213.               MPTVAL=IVAJAC
  214.               MELVAL = IVAL(1)
  215.               IBMN=MIN(IB, VELCHE(/2))
  216.               IGMN=MIN(IC, VELCHE(/1))
  217.               VELCHE(IGMN,IBMN)=ABS(DJAC)
  218.  9002       CONTINUE
  219.  9000     CONTINUE
  220. C
  221. C ----------------- Element JOI4
  222. C
  223.        ELSE IF (MELE.EQ.88) THEN
  224.          DO 8000 IB=1,NBELEM
  225.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  226.             DO 8002 IC=1,NBPGAU
  227.               DO      ID=1,6
  228.               DO      IE=1,NBNN
  229.                  SHP(ID,IE)=SHPTOT(ID,IE,IC)
  230.               ENDDO    
  231.               ENDDO    
  232.  
  233.               CALL JO4LOC(XE,SHPTOT,NBNN,XEL,BPSS,NOQUAL)
  234.               IF (NOQUAL.EQ.1) THEN
  235.                 INTERR(1)=IB
  236.                 MOTERR(1:4)='JOI4'
  237.                 CALL ERREUR(765)
  238.                 RETURN
  239.               ELSE IF(NOQUAL.EQ.2) THEN
  240.                 INTERR(1)=IB
  241.                 MOTERR(1:4)='JOI4'
  242.                 CALL ERREUR(766)
  243.                 RETURN
  244.               ENDIF
  245.  
  246.               NBNONN=NBNN/2
  247.            CALL DEVOLU(XEL,SHP,MFR,NBNONN,IFOUR,NIFOUR,2,1.D0,RR,DJAC)
  248.               IRRT = 0
  249.               IF (DJAC.LT.XZER) THEN
  250.                 IRRT = 1
  251.               ELSE IF(DJAC.EQ.XZER) THEN
  252.                 IRRT = 2
  253.               ENDIF
  254.               IF(IRRT.NE.0) THEN
  255.                  CALL ERREUR(764)
  256.                  RETURN
  257.               ENDIF
  258.  
  259.               MPTVAL=IVAJAC
  260.               MELVAL = IVAL(1)
  261.               IBMN=MIN(IB, VELCHE(/2))
  262.               IGMN=MIN(IC, VELCHE(/1))
  263.               VELCHE(IGMN,IBMN)=ABS(DJAC)
  264.  8002       CONTINUE
  265.  8000     CONTINUE
  266.  
  267.        ELSE
  268.          CALL ERREUR(767)
  269.          RETURN
  270.        ENDIF
  271. C
  272. C ================ FORMULATION MASSIVE =======================
  273. C
  274.       ELSE IF(MFR.EQ.1.OR.MFR.EQ.33.OR.MFR.EQ.73) THEN
  275.             DO 1000 IB=1,NBELEM
  276.             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  277.             DO 1002 IC=1,NBPGAU
  278.             DO      ID=1,6
  279.             DO      IE=1,NBNN
  280.             SHP(ID,IE)=SHPTOT(ID,IE,IC)
  281.       ENDDO    
  282.       ENDDO    
  283.            CALL JACOBI(XE,SHP,IDIM,NBNN,DJAC)
  284.             MPTVAL=IVAJAC
  285.            MELVAL = IVAL(1)
  286.             IBMN=MIN(IB, VELCHE(/2))
  287.             IGMN=MIN(IC, VELCHE(/1))
  288.            VELCHE(IGMN,IBMN)=ABS(DJAC)
  289.  1002 CONTINUE
  290.  1000 CONTINUE
  291.       GOTO 520
  292. C
  293. C ================ FORMULATION COQUE  MINCE =====================
  294. C
  295.       ELSE IF(MFR.EQ.3.OR.MFR.EQ.9) THEN
  296.         IDI2=IDIM-1
  297.         DO 3000 IB=1,NBELEM
  298.         CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  299. C
  300.          IF(IDIM.EQ.2)THEN
  301.            CALL VPAST2(XE,BPSS)
  302.          ELSE IF(IDIM.EQ.3) THEN
  303.            CALL VPAST(XE,BPSS)
  304.          ENDIF
  305.            CALL VCORL1(XE,XEL,BPSS,NBNN)
  306.          DO 3002 IC=1,NBPGAU
  307.          DO      ID=1,6
  308.          DO      IE=1,NBNN
  309.          SHP(ID,IE)=SHPTOT(ID,IE,IC)
  310.       ENDDO    
  311.       ENDDO    
  312.          CALL JACOBI(XEL,SHP,IDI2,NBNN,DJAC)
  313.          MPTVAL=IVAJAC
  314.           MELVAL = IVAL(1)
  315.           IBMN=MIN(IB, VELCHE(/2))
  316.           IGMN=MIN(IC,VELCHE(/1))
  317.          VELCHE(IGMN,IBMN)=ABS(DJAC)
  318.  3002 CONTINUE
  319.  3000 CONTINUE
  320.       GOTO 520
  321. C
  322. C ================ FORMULATION POUTRE ET TUYAU ====================
  323. C
  324.       ELSE IF(MFR.EQ.7.OR.MFR.EQ.13.OR.MFR.EQ.49) THEN
  325.          IDI2=IDIM-1
  326.          DO 7000 IB=1,NBELEM
  327.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  328. C
  329.          DO 7002 IC=1,NBPGAU
  330.          CALL POUJAC(XE,DJAC)
  331.          MPTVAL=IVAJAC
  332.           MELVAL = IVAL(1)
  333.           IBMN=MIN(IB, VELCHE(/2))
  334.           IGMN=MIN(IC, VELCHE(/1))
  335.          VELCHE(IGMN,IBMN)=DJAC
  336.  7002 CONTINUE
  337.  7000 CONTINUE
  338.       GOTO 520
  339. C
  340. C ================ FORMULATION COQUE  EPAISSE ====================
  341. C
  342.       ELSE IF(MFR.EQ.5) THEN
  343. C         NBPGA1=MINTE1.POIGAU(/1)
  344.          NBN1  =MINTE1.SHPTOT(/2)
  345.          SEGINI,TR1
  346. C
  347. C     UNE PETITE HORREUR ON CONSIDERE LES EPAISSEURS CONSTANTES
  348. C
  349.          DO 5010 IC=1,NBNN
  350.          TH(IC)=UN
  351.  5010 CONTINUE
  352.          DO 5000 IB=1,NBELEM
  353.          CALL DOXE(XCOOR,IDIM,NBNN,NUM,IB,XE)
  354. C
  355.          CALL CQ8LOC(XE,NBN1,MINTE1.SHPTOT,TXR,IRR)
  356. C
  357.          DO 5002 IC=1,NBPGAU
  358.          E=DZEGAU(IC)
  359.          CALL COQ8JC(IC,NBN1,E,XE,TH,TXR,SHPTOT,XJ,DJAC,IRR)
  360.          MPTVAL=IVAJAC
  361.           MELVAL = IVAL(1)
  362.           IBMN=MIN(IB, VELCHE(/2))
  363.           IGMN=MIN(IC, VELCHE(/1))
  364.          VELCHE(IGMN,IBMN)=ABS(DJAC)
  365.  5002 CONTINUE
  366.  5000 CONTINUE
  367.       GOTO 520
  368.       ENDIF
  369. C---------------------------------------------------------------------
  370. C  DESACTIVATION DES SEGMENTS PROPRES A LA ZONE GEOMETRIQUE ISOUS
  371. C---------------------------------------------------------------------
  372. C
  373.  520  CONTINUE
  374.       MPTVAL=IVAJAC
  375.       SEGSUP,MPTVAL,TRA
  376.  
  377.   500 CONTINUE
  378.  
  379.       SEGDES,MCOORD
  380.  
  381.       RETURN
  382. C
  383.  9990 CONTINUE
  384. *
  385. C-------------------------------------------------------------------
  386. C         ERREUR DANS UNE ZONE , DESACTIVATION ET RETOUR
  387. C-------------------------------------------------------------------
  388.       MPTVAL=IVAJAC
  389.       SEGSUP,MPTVAL
  390.  
  391. *      RETURN
  392.       END
  393.  
  394.  
  395.  
  396.  

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