Télécharger la plaquette Cast3M


fr en

Télécharger chapo.eso

Retour à la liste

Numérotation des lignes : 

chapo

  1. C CHAPO     SOURCE    CB215821  24/04/24    21:15:02     11916          
  2. C
  3.       SUBROUTINE CHAPO(IPMODL,IPCHAM,IPCARA,IPCHPO,IRET)
  4. C=======================================================================
  5. C
  6. C     TRANSFORME LE MCHAML IPCHAM EN CHPOINT IPCHPO
  7. C     il y a deja eu un reduaf sur IPMODL du mchaml -> IPCHAM
  8. C
  9. C=======================================================================
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12. -INC SMMODEL
  13. -INC SMCHAML
  14. c -INC SMCHPOI
  15. -INC SMELEME
  16. -INC SMCOORD
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC SMINTE
  21. -INC TMTRAV
  22. *
  23.       SEGMENT NOTYPE
  24.         CHARACTER*16 TYPE(NBTYPE)
  25.       ENDSEGMENT
  26.  
  27.       SEGMENT MPTVAL
  28.          INTEGER IPOS(NS),NSOF(NS),IVAL(NCOSOU)
  29.          CHARACTER*16 TYVAL(NCOSOU)
  30.       ENDSEGMENT
  31.  
  32.       SEGMENT INFO
  33.          INTEGER INFELL(JG)
  34.       ENDSEGMENT
  35.  
  36. c     tableau inverse pour retrouver la position d'inconnue
  37.       SEGMENT KINCO(NINCO)
  38.  
  39.       SEGMENT MWRK1
  40.          REAL*8 XEL(3,NBN1)
  41.       ENDSEGMENT
  42.  
  43.       SEGMENT MWRK2
  44.          REAL*8 TXR(3,3,NBN1),TH(NBN1)
  45.       ENDSEGMENT
  46.  
  47.       PARAMETER (LTIT=72)
  48.       CHARACTER*(LTIT) TITCH1
  49.       DIMENSION XIGAU(3)
  50.       DIMENSION INFOS(3)
  51. *      CHARACTER*(LCONMO) CONM
  52.       CHARACTER*(NCONCH) CONM
  53.  
  54.  
  55. ************************************************************************
  56. *     PRELIMINAIRES
  57. ************************************************************************
  58.       SEGACT MCOORD*MOD
  59. *
  60. *     ACTIVATION DU MMODEL et MCHAML
  61. *
  62.       IRET=1
  63.       MMODEL=IPMODL
  64.       MCHELM=IPCHAM
  65.       NSOUS=KMODEL(/1)
  66.       IF(IPCARA.GT.0) THEN
  67.         MCHEL1=IPCARA
  68.       ENDIF      
  69. *
  70. *     Verification du support : noeuds ou points d'integration (Gauss) ?
  71. *
  72.       ISUP = INFCHE(1,6)
  73.       NSC  = INFCHE(/1)
  74.       DO 50 ISC=2,NSC
  75.          ISUP1 = INFCHE(ISC,6)
  76.          IF (ISUP1.NE.ISUP) ISUP = 0
  77.  50   CONTINUE
  78. *     si ISUP = 1 : MCHAML aux noeuds
  79. *     si ISUP = 2 : MCHAML au centre de gravite
  80. *     si ISUP = 3 : MCHAML aux point d integration (rigidite)
  81. *     si ISUP = 4 : MCHAML aux point d integration (masse)
  82. *     si ISUP = 5 : MCHAML aux point d integration (stresses)
  83. *     si ISUP = 6 : MCHAML aux point d integration de T
  84. cbp   IF (ISUP.LT.1.OR.ISUP.GT.6) THEN
  85.       IF (ISUP.LE.1.OR.ISUP.GT.6) THEN
  86.          write(IOIMP,*) 'Supports incoherents',(INFCHE(iou,6),iou=1,NSC)
  87.          call erreur(609)
  88.          RETURN
  89.       ENDIF
  90.  
  91. c     on recupere TITCH1 dimensionné à 72 comme MOCHDE du SMCHPOI
  92.       LTIT1 = min(LTIT,TITCHE(/1))
  93.       TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  94.       TITCH1(1:LTIT1) = TITCHE(1:LTIT1)
  95.  
  96. c *     liste des composantes
  97. c *     ...
  98. c
  99. c *     Creation du MCHPOI puis du MSOUPO et du MPOVAL
  100. c *
  101. c       NAT = 2
  102. c       NSOUPO = 1
  103. c       SEGINI MCHPOI
  104. c       IPCHPO = MCHPOI
  105. c       MTYPOI = 'CHAN CHPO'
  106. c       MOCHDE(1:LTIT1) = TITCH1(1:LTIT1)
  107. c       IFOPOI = IFOUR
  108. c       JATTRI(1) = 2
  109. c       JATTRI(2) = 0
  110.  
  111. c       Segment MTRAV et ses dimensions
  112.         NNIN =0
  113.         NNNOE=0
  114.         MTRAV=0
  115.  
  116. ************************************************************************
  117. *     Boucle sur les zones du MCHAML
  118. ************************************************************************
  119.       isous = 0
  120.       DO 100 ISOU = 1,NSOUS
  121.  
  122. cbp          IVACOM = 0
  123.          IVAEP  = 0
  124.  
  125. *        ACTIVATION DU SOUS MODELE
  126.  
  127. c          IMODEL = KMODEL(ISOU)
  128.          IIIMOD = KMODEL(ISOU)
  129.          IMODEL = IIIMOD
  130.          IPMAIL = IMAMOD
  131.          CONM   = CONMOD
  132.          MELE   = NEFMOD
  133.          MELEME = IMAMOD
  134.          NFOR   = FORMOD(/2)
  135.          NMAT   = MATMOD(/2)
  136. c          write(6,*) '==== zone',ISOU,'/',NSOUS,' itypel =',itypel
  137.          IF (itypel.eq.48) goto 100
  138.          isous = isous+1
  139. c          write(6,*) '  => zone ok : ISOUS=', ISOUS
  140. *
  141. cbp         CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  142. *
  143. *        RECUP DU SEGMENT D'INTEGRATION MINTE
  144.          if(infmod(/1).lt.7) then
  145.           ISUP5 = MIN(ISUP,5)
  146.           CALL ELQUOI(MELE,0,ISUP5,IPINF,IMODEL)
  147.           IF (IERR.NE.0) THEN
  148.               write(*,*) 'erreur apres elquoi'
  149.               RETURN
  150.           ENDIF
  151.           INFO   = IPINF
  152.           NBGS   = INFELL(4)
  153.           MFR    = INFELL(13)
  154.           MINTE  = INFELL(11)
  155.           MINTE1 = INFELL(12)
  156.           segsup info
  157.          else
  158.           NBGS   = INFELE(4)
  159.           MFR    = INFELE(13)
  160.           MINTE  = INFMOD(ISUP+2)
  161.           MINTE1 = INFMOD(8)
  162.          endif
  163. *
  164.          IPMINT = MINTE
  165.          IF (MFR.EQ.5.AND.IPCARA.EQ.0) THEN
  166.             MOTERR(1:16) = 'CARACTERISTIQUES'
  167.             CALL ERREUR(565)
  168.             write(*,*) 'erreur manque IPCARA'
  169.             RETURN
  170.          ENDIF
  171.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGACT MINTE1
  172. *
  173.          CALL IDENT(IPMAIL,CONM,IPCHAM,0,INFOS,IRET)
  174. c          IF (IRET.EQ.0) call erreur(5)
  175. *
  176.          SEGACT MINTE
  177.          NBPGAU = POIGAU(/1)
  178.          NBN1 = NUM(/1)
  179.          NBELE1 = NUM(/2)
  180.          IF (ISUP.EQ.1) THEN
  181.            NIPO = NBN1
  182.          ELSE
  183.            NIPO = NBPGAU
  184.          ENDIF
  185.  
  186. *        creation des segments de travail
  187.          SEGINI MWRK1
  188.          NPPO = NIPO * NBELE1
  189. c          write(6,*) 'nb pts support', NIPO, '* nb elem',NBELE1,'=',NPPO
  190.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGINI MWRK2
  191.  
  192. *        ACTIVATION DU SOUS-MCHELM MCHAML
  193.          MCHAML = ICHAML(ISOUS)
  194.          NC     = IELVAL(/1)
  195. *
  196. *        CREATION/AJUSTEMENT DU MTRAV
  197. *        + REMPLISSAGE DE INCO et de KINCO
  198.          NINCO=NC
  199.          SEGINI,KINCO
  200. c       -1er passage :
  201.          IF(ISOUS.EQ.1) THEN
  202.            NNIN =NC
  203.            NNNOE1=0
  204.            NNNOE=NPPO
  205.            SEGINI,MTRAV
  206. c          toutes les composantes sont nouvelles
  207.            DO IC=1,NC
  208.              INCO(IC) = NOMCHE(IC)
  209.              NHAR(IC) = INFCHE(ISOU,3)
  210.              KINCO(IC)= IC
  211.            ENDDO
  212. c       -passages suivants :
  213.          ELSE
  214. c          on dimensionne au plus large
  215.            NNIN1=NNIN
  216.            NNIN =NNIN+NC
  217.            NNNOE1=NNNOE
  218.            NNNOE=NNNOE+NPPO
  219.            SEGADJ,MTRAV
  220. c          recherche des composantes nouvelles
  221. C          pour MCHAML
  222.            NCNEW=0
  223.            DO 101 IC=1,NC
  224.              DO 102 IIN=1,NNIN1
  225.                IF(INCO(IIN).NE.NOMCHE(IC)) GOTO 102
  226.                IF(NHAR(IIN).EQ.INFCHE(ISOU,3)) THEN
  227.                  KINCO(IC)=IIN
  228.                  GOTO 101
  229.                ENDIF
  230.  102         CONTINUE
  231. c            nouvelle composante !
  232.              NCNEW=NCNEW+1
  233.              INCO(NCNEW)=NOMCHE(IC)
  234.              NHAR(NCNEW)=INFCHE(ISOU,3)
  235.              KINCO(IC)=NCNEW
  236.  101       CONTINUE
  237. c          on remet a la bonne taille
  238.            NNIN=NNIN1+NCNEW
  239.            SEGADJ,MTRAV
  240.          ENDIF
  241.  
  242. *        + REMPLISSAGE DE IGEO et de IBIN
  243. c        sympa: a priori, tous les noeuds sont nouveaux !
  244.          NBPTS1 = NBPTS
  245.          DO INOE = NNNOE1 + 1,NNNOE
  246.            NBPTS = NBPTS  + 1
  247.            IGEO(INOE)=NBPTS
  248.            do IC=1,NC
  249.               IIN            = KINCO(IC)
  250.               IBIN(IIN,INOE) = 1
  251.            enddo
  252.          ENDDO
  253.          SEGADJ,MCOORD
  254. c          WRITE(*,*) 'INCO=',(INCO(iou),iou=1,NNIN)
  255. c        IN NE RESTE QU'A REMPLIR BB...
  256.  
  257. *
  258. *=======================================================================
  259. *        Boucle sur les composantes
  260.          DO 150 IC = 1,NC
  261.  
  262. c             write(6,*) '============ ISOU,IC=',ISOU,IC,'IMODEL=',IMODEL
  263. *           Recup du melval
  264.             MELVAL=IELVAL(IC)
  265. **
  266. *           Cas des coques epaisses : recup de l'epaisseur
  267. *           on neglige l'excentrement
  268.             IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  269.                NBROBL = 1
  270.                NBRFAC = 0
  271.                SEGINI NOMID
  272.                MOEP = NOMID
  273.                LESOBL(1) = 'EPAI'
  274.                NVEC = NBROBL + NBRFAC
  275.                NBTYPE = 1
  276.                SEGINI NOTYPE
  277.                MOTYPE = NOTYPE
  278.                TYPE(1) = 'REAL*8'
  279.                CALL KOMCHA(IPCARA,IPMAIL,CONM,MOEP,
  280.      &                     MOTYPE,1,INFOS,3,IVAEP)
  281.                SEGSUP NOTYPE
  282.             ENDIF
  283. *
  284. *           recup de la position IIN dans MTRAV
  285.             DO 151 IIN=1,NNIN
  286.                IF(INCO(IIN).EQ.NOMCHE(IC)) GOTO 152
  287.  151        CONTINUE
  288.             CALL ERREUR(5)
  289.             RETURN
  290.  152        CONTINUE
  291. *           + debut des nouveaux noeuds
  292.             INOE = NNNOE1
  293.  
  294. *
  295. *---------- Boucle sur les elements ------------------------------
  296. *
  297.             DO 200 IEL = 1,NBELE1
  298.  
  299. *              cas general
  300.                CALL DOXE(XCOOR,IDIM,NBN1,NUM,IEL,XEL)
  301. *
  302. *              coques epaisses
  303.                IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  304.                   MPTVAL=IVAEP
  305.                   MELVA1=IVAL(1)
  306.                   DO 201 IP = 1,NBN1
  307.                      IPMN=MIN(IP ,MELVA1.VELCHE(/1))
  308.                      IEMN=MIN(IEL,MELVA1.VELCHE(/2))
  309.                      TH(IP)=MELVA1.VELCHE(IPMN,IEMN)
  310.  201              CONTINUE
  311.                   CALL CQ8LOC(XEL,NBN1,MINTE1.SHPTOT,TXR,IRR)
  312.                ENDIF
  313. *
  314. *............. Boucle sur les points supports .............
  315. *
  316.                DO 300 IPSU = 1,NIPO
  317.  
  318.  
  319. *                 remplissage des valeurs CHAMELEM -> MTRAV
  320.                   IPMN = MIN(IPSU,VELCHE(/1))
  321.                   IEMN = MIN(IEL ,VELCHE(/2))
  322.                   INOE=INOE+1
  323.                   BB(IIN,INOE) = VELCHE(IPMN,IEMN)
  324. *
  325. cbp c                   IF (ISUP.GE.5) THEN
  326. cbp                   IF (ISUP.GT.1) THEN
  327. *                 1er passage : on calcule les coord du pt d integration
  328.                   IF (IC.EQ.1) THEN
  329.                      IF (ISUP.GE.5.AND.MFR.EQ.5) THEN
  330.                         Z = DZEGAU(IPSU)
  331.                         DO 400 I2 = 1,IDIM
  332.                            XIGAU(I2) = 0.D0
  333.                            DO 400 IL = 1,NBN1
  334.                               XIGAU(I2) = XIGAU(I2)+(SHPTOT(1,IL,IPSU)*
  335.      &                        XEL(I2,IL)+0.5D0*Z*TXR(I2,3,IL)*TH(IL))
  336.  400                    CONTINUE
  337.                      ELSE
  338.                         DO 410 I2 = 1,IDIM
  339.                            XIGAU(I2) = 0.D0
  340.                            DO 410 IL = 1,NBN1
  341.                               XIGAU(I2) = XIGAU(I2) +
  342.      &                        (SHPTOT(1,IL,IPSU)*XEL(I2,IL))
  343.  410                    CONTINUE
  344.                      ENDIF
  345.  
  346. *                    Le pdi est cree dans MCOORD
  347.                      KPTS=IGEO(INOE)
  348.                      XCOOR((KPTS-1)*(IDIM+1)+1) = XIGAU(1)
  349.                      XCOOR((KPTS-1)*(IDIM+1)+2) = XIGAU(2)
  350.                      IF (IDIM.EQ.3) XCOOR((KPTS-1)*(IDIM+1)+3)=XIGAU(3)
  351.                      XCOOR(KPTS*(IDIM+1)) = 0.D0
  352.                   ENDIF
  353.  
  354.  300           CONTINUE
  355. *............. fin de Boucle sur les points supports ..........
  356.  
  357.  200        CONTINUE
  358. *---------- Fin de Boucle sur les elements -----------------------
  359.  
  360.  150     CONTINUE
  361.  
  362. *        Fin de Boucle sur les composantes
  363. *=======================================================================
  364.  
  365. *        Desactivation des segments de la zone ISOU
  366. *
  367.          SEGSUP MWRK1
  368.          IF (ISUP.GE.5.AND.MFR.EQ.5) SEGSUP MWRK2
  369.          SEGSUP,KINCO
  370.  
  371. *
  372.  100  CONTINUE
  373. ************************************************************************
  374. *     FIN DE Boucle sur les zones du MCHAML
  375. ************************************************************************
  376.       SEGDES,MCOORD
  377.  
  378.  
  379. ************************************************************************
  380. *     CREATION DU CHPOINT FINAL A PARTIR DU MTRAV
  381. ************************************************************************
  382.       CALL CRECHP (MTRAV,IPCHP1)
  383.       SEGSUP,MTRAV
  384.       IPCHPO=IPCHP1
  385.  
  386.       END
  387.  
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  

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