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

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