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

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