Télécharger la plaquette Cast3M


fr en

Télécharger fpcoqu.eso

Retour à la liste

Numérotation des lignes : 

fpcoqu

  1. C FPCOQU    SOURCE    OF166741  24/10/07    21:15:18     12016          
  2.  
  3.       SUBROUTINE FPCOQU(P,IPCHE1,IPCHM1,IPMODL,JMLU,IPTFP,IRET)
  4. *_____________________________________________________________________
  5. *
  6. *   CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES
  7. *
  8. *   ENTREES :
  9. *   ---------
  10. *
  11. *    P        VALEUR DE LA PRESSION SI ELLE EST CONSTANTE
  12. *    IPCHE1   CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  13. *    IPCHM1   CHAMELEM CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  14. *    ICONV    FLAG DE CONVERSION
  15. *    IPMODL   OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION
  16. *    JMLU     1 SI MOT CLE NORMAL
  17. *             0 SINON IL FAUT APPELER PRORIE
  18. *             0   SI LE MOT CLE NORM A ETE INDIQUE
  19. *
  20. *   SORTIES :
  21. *   ---------
  22. *
  23. *    IPTFP    CHPOINT DES FORCES NODALES EQUIVALENTES
  24. *    IRET     1 OU 0 SUIVANT SUCCES OU NON
  25. *_____________________________________________________________________
  26.  
  27.       IMPLICIT INTEGER(I-N)
  28.       IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCHAMP
  33.  
  34. -INC SMCOORD
  35. -INC SMELEME
  36. -INC SMMODEL
  37. -INC SMCHAML
  38. -INC SMCHPOI
  39. -INC SMINTE
  40.  
  41.       SEGMENT NOTYPE
  42.         CHARACTER*16 TYPE(NBTYPE)
  43.       ENDSEGMENT
  44.  
  45.       SEGMENT MPTVAL
  46.         INTEGER IPOS(NS)    ,NSOF(NS)
  47.         INTEGER      IVAL(NCOSOU)
  48.         CHARACTER*16 TYVAL(NCOSOU)
  49.       ENDSEGMENT
  50.  
  51. *   Segment donnant le pointeur de maillage correcte au MCHAML de
  52. *   caracteristique apres creation d'un MMODEL
  53.       SEGMENT JPMAIL
  54.         INTEGER MAIL1 (NSOUS1)
  55.         INTEGER MAIL2 (NSOUS1)
  56.       ENDSEGMENT
  57.  
  58.       CHARACTER*8 MOT
  59.       CHARACTER*(NCONCH) CONM
  60.       PARAMETER (NINF=3)
  61.       INTEGER INFOS(NINF)
  62.       logical ltelq
  63.       INTEGER ISUPCA
  64.  
  65.       DATA MOT/'RIGIDITE'/
  66.  
  67.       IRET = 0
  68.  
  69.       IGEOM= 0
  70.  
  71.       lzero = 0
  72.  
  73.       nbtype = 1
  74.       SEGINI,notype
  75.       notype.TYPE(1) = 'REAL*8  '
  76.       MOTYR8 = notype
  77.  
  78.       nbrobl = 1
  79.       nbrfac = 0
  80.       SEGINI,nomid
  81.       nomid.LESOBL(1) = 'SCAL    '
  82.       MOSCAL = nomid
  83.  
  84.       NHRM=NIFOUR
  85.  
  86.       IFLAG=0
  87.       IVACAR=0
  88.       JPMAIL=0
  89.  
  90. * CHAMP PAR ELEMENT des CARACTERISTIQUES
  91.       IPCHE2 = 0
  92.       ISUPCA = 0
  93.       CALL LIROBJ('MCHAML  ',IPCHE2,0,IRT3)
  94.       IF (IERR.NE.0) RETURN
  95.  
  96. *     LE FLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE
  97. *     EN CAS DE CREATION  ( 0 : DESTRUCTION D'UN MMODEL CREE )
  98.  
  99.       IF (IPCHE1.NE.0.OR.IPCHM1.NE.0) THEN
  100. *
  101. *        ON CREE LE MMODEL S'ACCROCHANT AU CHPOINT
  102. *
  103. *        ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT
  104. *
  105.          IF (IPCHE1.NE.0) THEN
  106.            CALL NOMCOM(IPCHE1,'SCAL',IPCHE,IRETOU)
  107.            IF (IERR.NE.0) RETURN
  108.            MCHPOI=IPCHE
  109.            SEGACT MCHPOI
  110.            NSOUPO=IPCHP(/1)
  111.            IPGEOM = 0
  112.            DO 1140 I=1,NSOUPO
  113.               MSOUPO=IPCHP(I)
  114.               SEGACT MSOUPO
  115.               IF (IPGEOM.EQ.0) THEN
  116.                  IPGEOM = IGEOC
  117.               ELSE
  118.                  IPP2 = IGEOC
  119.                  ltelq=.false.
  120.                  CALL FUSE (IPGEOM,IPP2,IPPT,ltelq)
  121.                  IPGEOM = IPPT
  122.               ENDIF
  123. 1140       CONTINUE
  124. *
  125. *        ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHAMELEM
  126. *
  127.          ELSE
  128.            CALL ECROBJ('MCHAML  ',IPCHM1)
  129.            CALL ECRCHA('SCAL')
  130.            CALL NOMC
  131.            IF (IERR.NE.0) RETURN
  132.            CALL LIROBJ('MCHAML  ',IPCHE,1,IRETOU)
  133.            IF (IERR.NE.0) RETURN
  134.            MCHEL2=IPCHE
  135.            SEGACT MCHEL2
  136.            DO 1150 I=1,MCHEL2.IMACHE(/1)
  137.              IMTMP=MCHEL2.IMACHE(I)
  138.              IF (I.GT.1) THEN
  139.                ltelq=.false.
  140.                CALL FUSE (IPGEOM,IMTMP,IPPT,ltelq)
  141.                IPGEOM = IPPT
  142.              ELSE
  143.                IPGEOM = IMTMP
  144.              ENDIF
  145. 1150       CONTINUE
  146.          ENDIF
  147.          IF (IERR.NE.0) RETURN
  148.  
  149.          N1=0
  150.          SEGINI MMODEL
  151.          IPMOD=MMODEL
  152.  
  153.          MMODE1=IPMODL
  154.          NSOUS1=MMODE1.KMODEL(/1)
  155.  
  156. *      BOUCLE SUR LES SOUS ZONE GEOMETRIQUES ELEMENTAIRES
  157.          IRRT=0
  158.          DO 50 ISOUS=1,NSOUS1
  159.             IMODE1=MMODE1.KMODEL(ISOUS)
  160.             ITGEOM=IMODE1.IMAMOD
  161.             CALL ECROBJ('MAILLAGE',IPGEOM)
  162.             CALL ECRCHA('STRI')
  163.             CALL ECRCHA('APPU')
  164.             CALL ECROBJ('MAILLAGE',ITGEOM)
  165.             CALL EXTREL(IRR,0,IBNOR)
  166.             IF (IRR.EQ.0) THEN
  167. *
  168. *              ON A VERIFIER L ADHERENCE DU CHPOINT A CE MAILLAGE
  169. *
  170.                CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU)
  171.                IF (IERR.NE.0) THEN
  172.                   SEGSUP MMODEL
  173.                   RETURN
  174.                ENDIF
  175.                N1=N1+1
  176.                SEGADJ MMODEL
  177. *
  178. *              CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE
  179. *
  180.                NFOR=IMODE1.FORMOD(/2)
  181.                NMAT=IMODE1.MATMOD(/2)
  182.                MN3 =IMODE1.INFMOD(/1)
  183.                NPARMO=0
  184.                nobmod=0
  185.                SEGINI IMODEL
  186.                conmod(1:24)='        '
  187.                IMAMOD=IPOGEO
  188.                NEFMOD=IMODE1.NEFMOD
  189.                CONMOD=IMODE1.CONMOD
  190.                IPDPGE=IMODE1.IPDPGE
  191. *
  192. *              CREATION D'UN TABLEAU DE CORRESPONDANCE LE IMAMOD DU
  193. *              MMODEL (IPMODL) ET DU IMAMOD DU NVX MMODEL QUE L'ON CREE
  194. *              (UTILISE DANS LE KOMCHA POUR LE MCHAML DE CARATERISTIQUE
  195. *              POUR LES COQ6 ET COQ8)
  196. *
  197.                IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN
  198.                   IF (JPMAIL.EQ.0) SEGINI JPMAIL
  199.                   MAIL1(ISOUS)=ITGEOM
  200.                   MAIL2(ISOUS)=IPOGEO
  201.                ENDIF
  202.                DO 47 I=1,MN3
  203.                   INFMOD(I)=IMODE1.INFMOD(I)
  204.  47            CONTINUE
  205.                CONMOD=IMODE1.CONMOD
  206.                DO 48 I=1,NFOR
  207.                   FORMOD(I)=IMODE1.FORMOD(I)
  208.  48            CONTINUE
  209.                DO 49 I=1,NMAT
  210.                   MATMOD(I)=IMODE1.MATMOD(I)
  211.  49            CONTINUE
  212.                KMODEL(N1)=IMODEL
  213.                call inomid(imodel,lzero,lzero,lzero,lzero)
  214.                call prquoi(imodel)
  215.             ELSE
  216. *
  217. *              LE CHPOINT OU CHAMELEM N'ADHERE PAS A CETTE ZONE
  218. *
  219.                IRRT=IRRT+1
  220.             ENDIF
  221.  50      CONTINUE
  222. *
  223.          IF (NSOUPO.GT.1) THEN
  224.             MELEME=IPGEOM
  225.             SEGSUP MELEME
  226.          ENDIF
  227. *
  228.          IF (IRRT.EQ.NSOUS1) THEN
  229. *
  230. *           L'OBJET MAILLAGE ET LE CHPOINT OU CHAMELEM SONT INCOMPATIBLES
  231. *
  232.             MOTERR(1:8)='MAILLAGE'
  233.             IF (IPCHE1.NE.0) THEN
  234.               MOTERR(9:16)='CHPOINT'
  235.             ELSE
  236.               MOTERR(9:16)='CHAMELEM'
  237.             ENDIF
  238.             CALL ERREUR(135)
  239.             MMODEL=IPMOD
  240.             SEGSUP MMODEL
  241.             IF (JPMAIL.NE.0) SEGSUP JPMAIL
  242.             RETURN
  243.          ENDIF
  244.          IPMODI=IPMOD
  245.       ELSE
  246.          IPMODI=IPMODL
  247.          IFLAG=1
  248.       ENDIF
  249. *
  250. *-------EN 3D  ET DANS LE CAS OU NORM N'A PAS ETE INDIQUE
  251. *              ON CHARGE PRORIE DE REORIENTER LES ELEMENTS
  252. *
  253.       IF (IDIM.EQ.3.AND.JMLU.EQ.0) THEN
  254.          MMODE1=IPMODI
  255.          NSOUS=MMODE1.KMODEL(/1)
  256.          N1=NSOUS
  257.          SEGINI MMODEL
  258.          IPMOD=MMODEL
  259.          NBELEM=0
  260.          NBNN=0
  261.          NBREF=0
  262.          NBSOUS=NSOUS
  263.          SEGINI MELEME
  264.          DO 9 ISOUS=1,NSOUS
  265.             IMODEL=MMODE1.KMODEL(ISOUS)
  266.             LISOUS(ISOUS)=IMAMOD
  267.  9       CONTINUE
  268. *
  269. *        MAILLAGE A REORIENTER
  270. *
  271.          CALL ECROBJ('MAILLAGE',MELEME)
  272. *
  273. *        ORIENTATION PRORIE LIT LES DONNEES QUI LE CONCERNE
  274. *
  275.          CALL PRORIE
  276. *
  277. *        MAILLAGE REORIENTE
  278. *
  279.          CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  280.          IF (IERR.NE.0) THEN
  281.             SEGSUP MMODEL
  282.             IF (IFLAG.EQ.0) CALL DTMODL(IPMODI)
  283.             IF (JPMAIL.NE.0) SEGSUP JPMAIL
  284.             RETURN
  285.          ENDIF
  286.          SEGACT MELEME
  287.          DO 10 ISOUS=1,NSOUS
  288.             IMODE1=MMODE1.KMODEL(ISOUS)
  289.             SEGACT IMODE1
  290.             NFOR=IMODE1.FORMOD(/2)
  291.             NMAT=IMODE1.MATMOD(/2)
  292.             MN3 =IMODE1.INFMOD(/1)
  293.             NPARMO=0
  294.             nobmod=0
  295.             SEGINI IMODEL
  296.             conmod(1:24)='        '
  297.             KMODEL(ISOUS)=IMODEL
  298. *
  299. *           IMAMOD REORIENTE
  300. *
  301.             IMAMOD=LISOUS(ISOUS)
  302.             NEFMOD=IMODE1.NEFMOD
  303.             CONMOD=IMODE1.CONMOD
  304.             IPDPGE=IMODE1.IPDPGE
  305. *
  306. *           MISE A JOUR DU TABLEAU DE CORRESONDANCE DES IMAMOD
  307. *
  308.             IF (NEFMOD.EQ.41.OR.NEFMOD.EQ.56) THEN
  309.                IF (JPMAIL.EQ.0) THEN
  310.                   NSOUS1=NSOUS
  311.                   SEGINI JPMAIL
  312.                ENDIF
  313.                IF (IFLAG.EQ.1) MAIL1(ISOUS)=IMODE1.IMAMOD
  314.                MAIL2(ISOUS)=IMAMOD
  315.             ENDIF
  316.             CONMOD=IMODE1.CONMOD
  317.             DO 1 I=1,NFOR
  318.                FORMOD(I)=IMODE1.FORMOD(I)
  319.  1          CONTINUE
  320.             DO 2 I=1,NMAT
  321.                MATMOD(I)=IMODE1.MATMOD(I)
  322.  2          CONTINUE
  323.             DO 3 I=1,MN3
  324.                INFMOD(I)=IMODE1.INFMOD(I)
  325.  3          CONTINUE
  326.             IF (IFLAG.NE.1) THEN
  327.                SEGSUP IMODE1
  328.             ENDIF
  329.             call inomid(imodel,lzero,lzero,lzero,lzero)
  330.             call prquoi(imodel)
  331.  10      CONTINUE
  332.          IF (IFLAG.NE.1) SEGSUP MMODE1
  333.          IFLAG=0
  334.       ELSE
  335.          IPMOD=IPMODI
  336.       ENDIF
  337. *
  338. *     EN 2D ET EN 3D , ON VERIFIE QUE 2 ELEMENTS ADJACENTS
  339. *     ONT LA MEME ORIENTATION
  340. *
  341.       MMODEL=IPMOD
  342.       DO 11 ISOUS=1,KMODEL(/1)
  343.          IMODEL=KMODEL(ISOUS)
  344.          IF (ISOUS.GT.1) THEN
  345.             IPTGEO=IMAMOD
  346.             ltelq=.false.
  347.             CALL FUSE(IGEOM,IPTGEO,IPPT,ltelq)
  348.             IGEOM=IPPT
  349.          ELSE
  350.             IGEOM=IMAMOD
  351.          ENDIF
  352. 11    CONTINUE
  353.       CALL ECROBJ('MAILLAGE',IGEOM)
  354.       CALL VERSEN
  355.       CALL LIROBJ('MAILLAGE',IGEOM,1,IRETOU)
  356.       IF (IERR.NE.0) GOTO 9990
  357.  
  358.       IF (KMODEL(/1).GT.1) THEN
  359.          MELEME=IGEOM
  360.          SEGSUP MELEME
  361.       ENDIF
  362. *
  363. *     ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM
  364. *
  365.       IF (IPCHE1.EQ.0.AND.IPCHM1.EQ.0) THEN
  366.         CALL ZEROP(IPMOD,MOT,IPCH1)
  367.         IF (IERR.NE.0) RETURN
  368.         MCHEL1=IPCH1
  369.         SEGACT MCHEL1
  370.         NSOUS=MCHEL1.ICHAML(/1)
  371.         DO 12 ISOUS=1,NSOUS
  372.            MCHAM1=MCHEL1.ICHAML(ISOUS)
  373.            SEGACT MCHAM1
  374.            MELVA1=MCHAM1.IELVAL(1)
  375.            SEGACT MELVA1*MOD
  376.            N1PTEL=MELVA1.VELCHE(/1)
  377.            N1EL  =MELVA1.VELCHE(/2)
  378.            DO IB=1,N1EL
  379.              DO IGAU=1,N1PTEL
  380.                MELVA1.VELCHE(IGAU,IB)=P
  381.              ENDDO
  382.            ENDDO
  383.  12     CONTINUE
  384.       ELSE IF (IPCHE1.NE.0) THEN
  385. *
  386. *        On transforme le CHPOINT en MCHAML aux pts de Gauss pour la rigidite
  387. *
  388.          CALL CHAME1(0,IPMOD,IPCHE,' ',IPCH1,3)
  389.          IF (IERR.NE.0) GOTO 9990
  390.       ELSE
  391. *
  392. *       On change eventuellement le support du MCHAML
  393. *
  394.         CALL QUESUP(0,IPCHE,0,0,ISUP1,ISUP2)
  395.         IPCH1=IPCHE
  396.       ENDIF
  397.  
  398. *   Verification du lieu support du MCHAML de caracteristiques
  399.       IF (IPCHE2.NE.0) THEN
  400.         CALL QUESUP(IPMODL,IPCHE2,3,1,ISUPCA,iretca)
  401.         IF (ISUPCA.GT.1) GOTO 9990
  402.       ENDIF
  403.  
  404. *     ACTIVATION DU MODEL
  405. *
  406.       MMODEL=IPMOD
  407.       NSOUS=KMODEL(/1)
  408.  
  409.       DO 100 ISOUS=1,NSOUS
  410.  
  411.         IVAFOR=0
  412.         IVASCA=0
  413.         IVACAR=0
  414.         MOCARA = 0
  415. *
  416. *     TRAITEMENT DU MODEL
  417. *
  418.         IMODEL=KMODEL(ISOUS)
  419. *
  420. *     ON RECUPERE L INFORMATION GENERALE
  421. *
  422.         IPMAIL = IMAMOD
  423.         CONM   = CONMOD
  424.         MELE   = NEFMOD
  425.  
  426.         MELEME = IPMAIL
  427.         NBELEM = meleme.NUM(/2)
  428.         NBNN   = meleme.NUM(/1)
  429. *
  430. *        INFORMATION SUR L ELEMENT FINI
  431. *
  432.         MFR     = imodel.INFELE(13)
  433.         IPTINT  = imodel.INFMOD(5)
  434.         IPTNOE  = imodel.INFELE(12)
  435. *        IPTNOE = imodel.INFMOD(8)
  436.         IPPORE=0
  437.         IF (MFR.EQ.33) IPPORE=NBNN
  438. *
  439. *        RECHERCHE DU MELVAL DU CHAMELEM DE PRESSION
  440. *
  441. *       CREATION DU TABLEAU INFO
  442.         CALL IDENT(IPMAIL,CONM,IPCH1,0,INFOS,IRTD)
  443.         IF (IRTD.EQ.0) GOTO 910
  444. *
  445.         CALL KOMCHA(IPCH1,IPMAIL,CONM,MOSCAL,MOTYR8,1,INFOS,3,IVASCA)
  446.         IF (IERR.NE.0) GOTO 910
  447.         MPTVAL = IVASCA
  448.         IPTVPR = IVAL(1)
  449. *
  450. *     CHANGEMENT EVENTUEL DU SUPPORT DANS LE CAS OU UN MCHAML A ETE FOURNI
  451. *
  452.         IF (IPCHM1.NE.0) THEN
  453.           IF (ISUP2.EQ.4) THEN
  454.             CALL ERREUR(609)
  455.             GOTO 910
  456.           ELSE IF (ISUP2.EQ.1) THEN
  457.             IVPRES = IPTVPR
  458.             CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  459.           ENDIF
  460.         ENDIF
  461. *
  462. *        RECHERCHE DES NOMS DE COMPOSANTES
  463. *
  464.         nomid = imodel.LNOMID(2)
  465.         if (nomid.ne.0) then
  466.           MOFORC=nomid
  467.           nfor=lesobl(/2)
  468.           nfac=0
  469.         else
  470.           CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  471.           write(ioimp,*) 'FPCOQU : MOFORC = 0'
  472.           call erreur(5)
  473.         endif
  474.         NCOMP=NFOR
  475.         IF (IFOUR.EQ.-3) NCOMP=NFOR-3
  476. *
  477. *        CREATION DU MCHAML DE LA SOUS ZONE
  478. *
  479.          IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45.OR.MELE.EQ.93) THEN
  480.             N1PTEL=3
  481.          ELSE IF (MELE.EQ.44) THEN
  482.             N1PTEL=2
  483.          ELSE IF (MELE.EQ.49.OR.MELE.EQ.41.OR.MELE.EQ.56) THEN
  484.             N1PTEL=NBNN
  485.          ELSE
  486. *
  487. *           ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  488. *
  489.             MOTERR(1:4)=NOMTP(MELE)
  490.             MOTERR(5:12)='FPCOQU  '
  491.             CALL ERREUR(86)
  492.             GOTO 910
  493.          ENDIF
  494. *
  495.          N1EL=NBELEM
  496.          N2PTEL=0
  497.          N2EL  =0
  498.          N2=NCOMP
  499.          SEGINI MCHAML
  500.          NS=1
  501.          NCOSOU=NCOMP
  502.          SEGINI MPTVAL
  503.          IVAFOR=MPTVAL
  504.          NOMID=MOFORC
  505.          DO 4 ICOMP=1,NCOMP
  506.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  507.             TYPCHE(ICOMP)='REAL*8'
  508.             SEGINI MELVAL
  509.             IELVAL(ICOMP)=MELVAL
  510.             IVAL(ICOMP)=MELVAL
  511.  4       CONTINUE
  512. *_______________________________________________________________________
  513. *
  514. *          CALCUL DES FORCES NODALES EQUIVALENTES
  515. *        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  516. *_______________________________________________________________________
  517. *
  518.       IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.45
  519.      1                     .OR.MELE.EQ.93) THEN
  520. *
  521. *        ELEMENTS COQ3 , DKT OU DKTC
  522. *        ---------------------------
  523.          CALL FPCO3D(IPTVPR,IPMAIL,IVAFOR)
  524.       ELSE IF (MELE.EQ.44) THEN
  525. *
  526. *        ELEMENT COQ2
  527. *        ------------
  528. *
  529. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  530. *
  531.          IF (IFOUR.EQ.-2 .AND.IPCHE2.NE.0) THEN
  532. *
  533. *        CREATION DU TABLEAU INFO
  534. *
  535.              CALL IDENT(IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  536.              IF (IRTD.EQ.0) GOTO 910
  537.  
  538.              NBROBL=0
  539.              NBRFAC=1
  540.              SEGINI NOMID
  541.              LESFAC(1)='DIM3'
  542.  
  543.              NCARA=NBROBL
  544.              NCARF=NBRFAC
  545.              NCARR=NCARA+NCARF
  546.              MOCARA = NOMID
  547.  
  548.              CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0,
  549.      +                                       INFOS,3,IVACAR)
  550.              IF (IERR.NE.0) GOTO 910
  551. *
  552.              IF (ISUP.EQ.1) THEN
  553.                CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  554.              ENDIF
  555.          ENDIF
  556. *
  557.          CALL FPCO2D (IPTVPR,IPMAIL,IVAFOR,IVACAR)
  558. *
  559. *        ELEMENTS COQ4
  560. *        -------------
  561.       ELSE IF (MELE.EQ.49) THEN
  562.          CALL FPCOQ4(IPTVPR,IPMAIL,IPTINT,IVAFOR)
  563. *
  564. *        ELEMENTS COQ6 OU COQ8
  565. *        ---------------------
  566.       ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  567.          IF (IPCHE2.EQ.0) THEN
  568. * Message a affiner
  569.            write(ioimp,*) 'Manque CARACTERISTIQUES COQ6&COQ8'
  570.            CALL ERREUR(21)
  571.            GOTO 910
  572.          ENDIF
  573. *____________________________________________________________________
  574. *
  575. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  576. *              CARACTERISTIQUES POUR LES COQ8 ET COQ6
  577. *____________________________________________________________________
  578. *
  579.          NBROBL=1
  580.          NBRFAC=0
  581.          SEGINI NOMID
  582.          LESOBL(1)='EPAI'
  583.  
  584.          NCARA=NBROBL
  585.          NCARF=NBRFAC
  586.          NCARR=NCARA+NCARF
  587.          MOCARA=NOMID
  588.  
  589.          IF (IFLAG.EQ.0) THEN
  590. *
  591. *           ON RECUPERE LE IMAMOD DU MMODEL D'ORIGINE POUR QUE LE IPMAIL
  592. *           DONNE CORRESPONDE A CELUI DE IPCHE21
  593. *
  594.             DO 60 KISOUS=1,NSOUS1
  595.                IF (IPMAIL.EQ.MAIL2(KISOUS)) THEN
  596.                   IPMAI1=MAIL1(KISOUS)
  597.                   GOTO 61
  598.                ENDIF
  599.  60         CONTINUE
  600. *
  601. *           NE DOIT NORMALEMENT JAMAIS SE PRODUIRE
  602. *
  603.             CALL ERREUR(472)
  604.             GOTO 910
  605. 61         CONTINUE
  606.          ELSE
  607.            IPMAI1=IPMAIL
  608.          ENDIF
  609.  
  610.          CALL KOMCHA(IPCHE2,IPMAI1,CONM,MOCARA,MOTYR8,1,INFOS,3,IVACAR)
  611.          IF (IERR.NE.0) GOTO 910
  612.  
  613.          IF (ISUPCA.EQ.1) THEN
  614.             CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  615.          ENDIF
  616.  
  617.          CALL FPCOQ8(IPTVPR,IPMAIL,IPTINT,IVACAR,IPTNOE,IVAFOR)
  618.  
  619.       ELSE
  620. *
  621. *        ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  622. *
  623.          MOTERR(1:4)=NOMTP(MELE)
  624.          MOTERR(5:12)='FPCOQU'
  625.          CALL ERREUR(86)
  626.          GOTO 910
  627.       ENDIF
  628. *
  629. *     INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  630. *
  631.         N1=1
  632.         L1=6
  633.         N3=6
  634.         SEGINI,MCHELM
  635.         IPCHEL=MCHELM
  636.         mchelm.TITCHE = 'FORCES'
  637.         mchelm.IFOCHE = IFOUR
  638.         mchelm.IMACHE(1) = IPMAIL
  639.         mchelm.CONCHE(1) = CONM
  640.         mchelm.ICHAML(1) = MCHAML
  641.         mchelm.INFCHE(1,1) = 0
  642.         mchelm.INFCHE(1,2) = 0
  643.         mchelm.INFCHE(1,3) = NHRM
  644.         mchelm.INFCHE(1,4) = IPTINT
  645.         mchelm.INFCHE(1,5) = 0
  646.         mchelm.INFCHE(1,6) = 3
  647. *
  648. *     ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  649. *
  650.         CALL CHAMPO(IPCHEL,0,IPCHPO,IRET)
  651.         CALL DTCHAM(IPCHEL)
  652.         IF (IRET.EQ.0) GOTO 910
  653.  
  654.         IF (ISOUS.GT.1) THEN
  655.           CALL ADCHPO(IPCHPO,IPTFP,IRET,1D0,1D0)
  656.           CALL DTCHPO(IPCHPO)
  657.           CALL DTCHPO(IPTFP)
  658.           IF (IRET.EQ.0) GOTO 910
  659.           IPTFP=IRET
  660.         ELSE
  661.           IPTFP=IPCHPO
  662.         ENDIF
  663.         ISOK = 1
  664.  
  665.  910    CONTINUE
  666.         IF (ISUPCA.EQ.1) THEN
  667.           CALL DTMVAL(IVACAR,3)
  668.         ELSE
  669.           CALL DTMVAL(IVACAR,1)
  670.         ENDIF
  671.         MPTVAL = IVASCA
  672.         IF (mptval.NE.0) SEGSUP,MPTVAL
  673.  
  674.         MPTVAL = IVAFOR
  675.         IF (mptval.NE.0) SEGSUP,MPTVAL
  676.  
  677.         NOMID = MOCARA
  678.         IF (nomid.NE.0) SEGSUP,NOMID
  679.  
  680. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  681.         IF (ISOK .NE. 1) GOTO 9997
  682.  
  683.  100  CONTINUE
  684.  
  685.       IRET = 1
  686. *
  687. *  FIN :
  688.  9997 CONTINUE
  689.       notype = MOTYR8
  690.       SEGSUP,notype
  691.       nomid = MOSCAL
  692.       SEGSUP,nomid
  693.  
  694.  9990 CONTINUE
  695.       IF (IFLAG.EQ.0) CALL DTMODL(IPMOD)
  696.       IF (JPMAIL.NE.0) SEGSUP,JPMAIL
  697.  
  698.       RETURN
  699.       END
  700.  
  701.  
  702.  

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