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

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