Télécharger la plaquette Cast3M


fr en

Télécharger fpmass.eso

Retour à la liste

Numérotation des lignes : 

fpmass

  1. C FPMASS    SOURCE    OF166741  25/02/21    21:16:44     12166          
  2.  
  3. C_____________________________________________________________________
  4. C
  5. C   CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES MASSIFS
  6. C
  7. C   ENTREES :
  8. C   ---------
  9. C
  10. C    IPCHE1   CHPOINT CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  11. C              DE LA FACE D UN MASSIF
  12. C    IPCHM1   CHAMELEM CONTENANT LES VALEURS DES PRESSIONS AUX NOEUDS
  13. C              DE LA FACE D UN MASSIF
  14. C    IPMODL   OBJET MODELE  SUR LEQUEL S APPLIQUE LA PRESSION
  15. C
  16. C    JPMAIL   POINTEUR SUR LE MAILLAGE SI ON A LU UN FLOTTANT ET
  17. C             UN MAILLAGE, SINON 0
  18. C
  19. C    XP       LA VALEUR DE LA PRESSION SI ON L'A LUE
  20. C
  21. C  SORTIES  :
  22. C  ----------
  23. C
  24. C    IPTFP  = CHPOINT DES FORCES NODALES EQUIVALENTES
  25. C    IRET   = 1 OU 0 SUIVANT SUCCES OU NON
  26. C
  27. C     REVISION JACQUELINE BROCHARD  SEPTEMBRE 86
  28. C     MISE A JOUR P VERPEAUX MAI 88
  29. C
  30. C     PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 17 09 90
  31. C_______________________________________________________________________
  32.  
  33.       SUBROUTINE FPMASS(IPCHE1,IPCHM1,IPMODL,IPTFP,JPMAIL,XP,IRET)
  34.  
  35.       IMPLICIT INTEGER(I-N)
  36.       IMPLICIT REAL*8(A-H,O-Z)
  37.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC CCREEL
  41. -INC CCHAMP
  42.  
  43. -INC SMCOORD
  44. -INC SMELEME
  45. -INC SMMODEL
  46. -INC SMCHAML
  47. -INC SMCHPOI
  48. -INC SMINTE
  49.  
  50. -INC TMPTVAL
  51.  
  52.       SEGMENT INFO
  53.         INTEGER INFELL(JG)
  54.       ENDSEGMENT
  55.  
  56.       SEGMENT NOTYPE
  57.         CHARACTER*16 TYPE(NBTYPE)
  58.       ENDSEGMENT
  59.  
  60.       segment netn(nonetn)
  61.       segment ietn(letn)
  62.  
  63.       CHARACTER*4 MOSTRI,MOAPPU,MOGEOM
  64.       CHARACTER*(NCONCH) CONM
  65.       PARAMETER (NINF=3)
  66.       INTEGER INFOS(NINF)
  67.       LOGICAL LSUPFO,ltelq
  68.  
  69.       DATA MOAPPU/'APPU'/,MOSTRI/'STRI'/
  70.       DATA MOGEOM/'GEOM'/
  71.  
  72.       IRET = 0
  73.       IGEOM = 0
  74.  
  75.       NHRM=NIFOUR
  76.  
  77. C-----------------------------------------------------------------------
  78. C LECTURE DU CHAMP DE CARACTERISTIQUES
  79. C-----------------------------------------------------------------------
  80.       IPCHE2 = 0
  81.       ISUPCA = 0
  82. C Prevoir la lecture en amont !
  83.       CALL LIROBJ('MCHAML  ',IPCHE2,0,irt2)
  84.       IF (IERR.NE.0) RETURN
  85.       IF (IPCHE2.NE.0) THEN
  86.         CALL ACTOBJ('MCHAML  ',IPCHE2,1)
  87.         IF (IERR.NE.0) RETURN
  88.  
  89.         CALL REDUAF(IPCHE2,MODORI,ipche20,0,iretca,kerr)
  90.         if (iretca.ne.1) call erreur(kerr)
  91.         IF (IERR.NE.0) RETURN
  92.         IPCHE2 = ipche20
  93. C
  94. C   Verification du lieu support du MCHAML de caracteristiques
  95. C
  96.         CALL QUESUP(IPMODL,IPCHE2,3,1,ISUPCA,iretca)
  97.         IF (ISUPCA.GT.1) RETURN
  98.       ENDIF
  99. C-----------------------------------------------------------------------
  100. C   CAS OU UN CHPOINT EST FOURNI
  101. C   ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  102.       IF (JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  103.         MCHPOI=IPCHE1
  104.         ltelq=.false.
  105.         DO I=1,IPCHP(/1)
  106.            MSOUPO=IPCHP(I)
  107.            IF (I.GT.1) THEN
  108.               CALL FUSE(IGEOM,IGEOC,IPPT,ltelq)
  109.               IGEOM=IPPT
  110.            ELSE
  111.               IGEOM=IGEOC
  112.            ENDIF
  113.         ENDDO
  114.         IF (IERR.NE.0) RETURN
  115.       ENDIF
  116. C-----------------------------------------------------------------------
  117. C   CAS OU UN CHAMELEM EST FOURNI
  118. C   ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  119.       IF (IPCHM1.NE.0) THEN
  120.         MCHEL2 = IPCHM1
  121.         ltelq=.false.
  122.         DO I=1,MCHEL2.IMACHE(/1)
  123.           IMTMP=MCHEL2.IMACHE(I)
  124.           IF (I.GT.1) THEN
  125.             CALL FUSE(IGEOM,IMTMP,IPPT,ltelq)
  126.             IGEOM=IPPT
  127.           ELSE
  128.             IGEOM=IMTMP
  129.           ENDIF
  130.         ENDDO
  131.         IF (IERR.NE.0) RETURN
  132.       ENDIF
  133.  
  134. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  135.       IF (IFOUR.EQ.-3) THEN
  136.         NDPGE=3
  137.       ELSE IF (IFOUR.EQ.11) THEN
  138.         NDPGE=2
  139.       ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR.
  140.      &         IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  141.         NDPGE=1
  142.       ELSE
  143.         NDPGE=0
  144.       ENDIF
  145.  
  146. C- Un petit segment toujours utile :
  147.       nbtype = 1
  148.       SEGINI,notype
  149.       notype.TYPE(1) = 'REAL*8  '
  150.       MOTYR8 = notype
  151.  
  152. c- Segments utiles pour accelerer la recherche des elements touchant un noeud.
  153.       SEGACT,mcoord
  154.       nonetn = nbpts+1
  155.       netn = 0
  156.       ietn = 0
  157. C
  158. C     TRAITEMENT DU MODELE
  159. C
  160.       MMODEL = IPMODL
  161.       NSOUS  = mmodel.KMODEL(/1)
  162.  
  163.       IRRT=0
  164.       DO 100 ISOUS = 1, NSOUS
  165. C
  166.         ISOK = 0
  167.         MOCARA = 0
  168.         IVACAR = 0
  169. C
  170. C        TRAITEMENT DU MODELE
  171. C
  172.         IMODEL = mmodel.KMODEL(ISOUS)
  173.         IPMAIL = imodel.IMAMOD
  174.         CONM   = imodel.CONMOD
  175.         MELM   = imodel.NEFMOD
  176.  
  177. C*         write(*,*) ISOUS,'/',NSOUS,' : ',IMODEL,'NEFMOD=',MELM
  178.          if ((melm .eq. 22).OR.(melm .eq. 259)) then
  179. C      ... Ici sous modele de multiplicateur de lagrange on
  180. C          incrémente le compteur et on passe à la zone suivante ...
  181.             IRRT=IRRT+1
  182.             GOTO 100
  183.          endif
  184. C
  185. C        ON RECUPERE LES ELTS DE L ENVELOPPE DU MASSIF APPUYES
  186. C        STRICTEMENT SUR LE CHPOINT DE PRESSIONS OU appartenant au
  187. C        MAILLAGE DONNE
  188. C
  189.          CALL ECROBJ('MAILLAGE',IPMAIL)
  190.          IF (IDIM.EQ.2) THEN
  191.            CALL PRCONT
  192.          ELSE IF (IDIM.EQ.3) THEN
  193.            CALL ENVELO
  194.          ELSE IF (IDIM.EQ.1) THEN
  195.            CALL PREX1D
  196.          ENDIF
  197.          IF (IERR.NE.0) GOTO 9900
  198.          CALL LIROBJ('MAILLAGE',ienvel,1,iretou)
  199.          IF (IERR .NE. 0) GOTO 9900
  200.          CALL ACTOBJ('MAILLAGE',ienvel,1)
  201.  
  202. C     ... si un CHPOINT a été donné, on va chercher la partie de
  203. C         l'enveloppe s'appuyant strictement sur le support du CHPOINT ...
  204.          IF (JPMAIL.EQ.0) THEN
  205.               CALL ECROBJ('MAILLAGE',IGEOM)
  206.               CALL ECRCHA(MOSTRI)
  207.               CALL ECRCHA(MOAPPU)
  208.               CALL ECROBJ('MAILLAGE',ienvel)
  209.               CALL EXTREL(IRR,0,IBNOR)
  210.          ELSE
  211. C      ... sinon, on va chercher l'intersection de l'enveloppe avec
  212. C          le maillage fourni ...
  213.               CALL INTERB(ienvel,jpmail,irr,IPOGEO)
  214.          ENDIF
  215. C      ... Ici on teste si intersection est vide, si OUI on
  216. C          incrémente le compteur et on passe à la zone suivante ...
  217.          IF (irr.gt.0) THEN
  218.               IRRT=IRRT+1
  219.               GOTO 100
  220.          ENDIF
  221.          IF (JPMAIL.EQ.0) THEN
  222.              CALL LIROBJ('MAILLAGE',IPOGEO,1,iret)
  223.              IF (IERR.NE.0) GOTO 9900
  224.              CALL ACTOBJ('MAILLAGE',IPOGEO,1)
  225.          ENDIF
  226.  
  227. C  pour accelerer la recherche, utilisation d'un tableau des elements touchant un noeud.
  228.         if (netn.EQ.0) THEN
  229.           segini,netn
  230.         else
  231.           do i = 1, nonetn
  232.             netn(i) = 0
  233.           enddo
  234.         endif
  235.         IPT1 = IPMAIL
  236.         nbnn1 = ipt1.num(/1)
  237.         nbel1 = ipt1.num(/2)
  238.         do j = 1, nbel1
  239.           do i = 1, nbnn1
  240.             ino = ipt1.num(i,j)
  241.             netn(ino) = netn(ino)+1
  242.           enddo
  243.         enddo
  244.         do i = 2, nonetn
  245.           netn(i) = netn(i) + netn(i-1)
  246.         enddo
  247.         letn = netn(nonetn)
  248.         if (ietn.eq.0) then
  249.           segini,ietn
  250.         else
  251.           if (letn.gt.ietn(/1)) segadj,ietn
  252.           do i = 1, letn
  253.             ietn(i) = 0
  254.           enddo
  255.         endif
  256.         do j = 1, nbel1
  257.           do i = 1, nbnn1
  258.             ino = ipt1.num(i,j)
  259.             ietn(netn(ino)) = j
  260.             netn(ino) = netn(ino)-1
  261.           enddo
  262.         enddo
  263.         ietn1 = ietn
  264.         netn1 = netn
  265.  
  266. C_______________________________________________________________________
  267. C
  268. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  269. C_______________________________________________________________________
  270.         NBROBL = 0
  271.         NBRFAC = 0
  272.         IF (IPCHE2.NE.0 .AND. IFOUR.EQ.-2) THEN
  273. C
  274. C       CREATION DU TABLEAU INFOS
  275. C
  276.           CALL IDENT(IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  277.           IF (IRTD.EQ.0) GOTO 9900
  278. C
  279.           NBRFAC=1
  280.           SEGINI,NOMID
  281.           LESFAC(1)='DIM3'
  282.           MOCARA = NOMID
  283. C
  284.           IF (ISUPCA.NE.1) THEN
  285.             CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0,
  286.      &                                     INFOS,3,IVACAR)
  287.             IF (IERR.NE.0) GOTO 9900
  288.           ENDIF
  289.         ENDIF
  290.         NCARA  = NBROBL
  291.         NCARF  = NBRFAC
  292.         NCARR  = NCARA+NCARF
  293. C
  294. C     ON DETERMINE LA FORMULATION ASSOCIEE A L OBJET
  295. C     GEOMETRIQUE ELEMENTAIRE DE SURFACE
  296. C
  297.         IPT3 = IPOGEO
  298.         NBSOU3 = IPT3.LISOUS(/1)
  299.         IPT2=IPT3
  300. C
  301. C     BOUCLE SUR LES SOUS ZONES DE L ENVELOPPE
  302. C
  303.         DO 110 IB=1,MAX(1,NBSOU3)
  304.  
  305.           MOFORC = 0
  306.           IVAFOR = 0
  307.           IVACA1 = 0
  308.           IPMOD1 = 0
  309.           IPTVPR = 0
  310.           lsupfo = .false.
  311.           ISOK = 0
  312.  
  313.           IF (NBSOU3.NE.0) THEN
  314.             IPT2=IPT3.LISOUS(IB)
  315.           ENDIF
  316.           IPOGEO=IPT2
  317.  
  318.           NBNN  = IPT2.NUM(/1)
  319.           LETYP = IPT2.ITYPEL
  320. C
  321. C     PETIT TEST SUR LE TYPE
  322.           IF (LETYP.EQ.1.AND.IDIM.NE.1) THEN
  323.             CALL ERREUR(16)
  324.             GOTO 9990
  325.           ENDIF
  326.           CALL TYPFAC(MELM,NBNN,MELE)
  327. C          write(*,*) 'TYPFAC --> MELE=',MELE
  328. C  ERREUR : IMPOSSIBLE D UTILISER L OPERATEUR PRESSI POUR
  329. C           LES ELEMENTS DE FORMULATION MELM
  330.           IF (MELE.EQ.0) THEN
  331.             MOTERR(1:8)=NOMTP(MELM)
  332.             CALL ERREUR(193)
  333.             GOTO 9990
  334.           ENDIF
  335. C
  336. C     CAS OU UN CHAMP PAR POINT A ETE FOURNI
  337. C     ON CREE L OBJET MODEL ASSOCIE A LA SURFACE ELEMENTAIRE
  338. C     ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM ELEMENTAIRE
  339.           IF (JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  340.             N1 = 1
  341.             SEGINI,MMODE1
  342.             NFOR = imodel.FORMOD(/2)
  343.             NMAT = imodel.MATMOD(/2)
  344. c*            MN3  = imodel.INFMOD(/1)
  345.             MN3    = 1
  346.             NPARMO = 0
  347.             NOBMOD = 0
  348.             SEGINI,IMODE1
  349.             imode1.IMAMOD = IPOGEO
  350.             imode1.NEFMOD = MELE
  351.             imode1.CONMOD = imodel.CONMOD
  352.             DO i = 1, NFOR
  353.               imode1.FORMOD(i) = imodel.FORMOD(i)
  354.             ENDDO
  355.             DO i = 1, NMAT
  356.               imode1.MATMOD(i) = imodel.MATMOD(i)
  357.             ENDDO
  358. c*            DO i = 1, MN3
  359. c*              imode1.INFMOD(i) = imodel.INFMOD(i)
  360. c*            ENDDO
  361. c*            lzero = 0
  362. c*            call inomid(imode1,lzero,lzero,lzero,lzero)
  363. c*            call prquoi(imode1)
  364.             mmode1.KMODEL(1) = IMODE1
  365.             IPMOD1 = MMODE1
  366. c* Il faut redefinir a chaque fois IPMOD1 pour eviter rappel du
  367. c* preconditionnement dans CHAME1 qui ne cree pas
  368.             CALL CHAME1(0,IPMOD1,IPCHE1,' ',ICHELP,3)
  369.             IF (IERR.NE.0) GOTO 9990
  370.             MCHEL1=ICHELP
  371.             MCHAM1=MCHEL1.ICHAML(1)
  372.             IPTVPR=MCHAM1.IELVAL(1)
  373.           ENDIF
  374. C
  375. C      INFORMATION SUR L'ELEMENT FINI
  376. C
  377.          CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  378. Cbp : on aurait voulu faire CALL ELQUOI(MELE,0,3,IPINF,IMODE1),
  379. C   : mais cela ne marche evidemment pas bien...
  380.          IF (IERR.NE.0) GOTO 9990
  381.          INFO=IPINF
  382.          IPTINT=INFELL(11)
  383.          MFR   =INFELL(13)
  384. C*OF En DIMEnsion 1, on force FORMULATION MASSIVE pour POI1
  385.          IF (IDIM.EQ.1.AND.MELE.EQ.45) MFR=1
  386.          IPPORE=0
  387.          IF (MFR.EQ.33) IPPORE=NBNN
  388. C Destruction immediate du segment
  389.          SEGSUP,INFO
  390. C_______________________________________________________________________
  391. C
  392. C RECHERCHE DES NOMS DE COMPOSANTES
  393. C_______________________________________________________________________
  394.           MOFORC = imodel.lnomid(2)
  395.           if (moforc.ne.0) then
  396.             lsupfo = .false.
  397.             nomid = moforc
  398.             nfor = lesobl(/2)
  399.             nfac = 0
  400. C            write(*,*) 'nomid deja existant dans IMODEL',IMODEL
  401.           else
  402.             lsupfo = .true.
  403.             CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  404.             write(ioimp,*) 'FPMASS : appel a IDFORC pour creer nomid'
  405.           endif
  406.           NCOMP=NFOR-NDPGE
  407.           NOMID=MOFORC
  408.  
  409. Cbp     on verifie qu on a suffisamment de composantes d'effort
  410.           NFO=0
  411.           IF (MELE.EQ.2  .OR. MELE.EQ.3) NFO=2
  412.           IF (MELE.EQ.31 .OR. MELE.EQ.32 .OR. MELE.EQ.33 .OR.
  413.      &        MELE.EQ.34) NFO=3
  414.           IF (MELE.EQ.45) NFO=1
  415.           IF (NFO.ne.0) THEN
  416.             IF (NCOMP.lt.NFO) GOTO 444
  417.             DO ICOMP=1,NFO
  418.               IF(LESOBL(ICOMP)(1:1).NE.'F') GOTO 444
  419.             ENDDO
  420.             GOTO 440
  421.           ENDIF
  422. C         -erreur
  423.  444      CONTINUE
  424.           write(IOIMP,*) 'on attend un MODELE avec au moins',NFO,
  425.      &                   'composantes de FORCES !'
  426.           write(IOIMP,*) 'Ici, on a :',(LESOBL(i),i=1,NCOMP)
  427.           MOTERR(1:16)='MECANIQUE, ...  '
  428.           CALL ERREUR(719)
  429.           GOTO 9990
  430. C         -pas d'erreur
  431.  440      CONTINUE
  432. C
  433. C        CAS OU UN CHAMP PAR ELEMENT A ETE FOURNI
  434. C        -> Verification de son support
  435. C
  436.          IF (IPCHM1.NE.0) THEN
  437.            CALL QUESUP(0,IPCHM1,0,0,ISUP1,ISUP2)
  438.            MCHEL2=IPCHM1
  439.            MCHAM2 = MCHEL2.ICHAML(1)
  440.            IF (ISUP2.NE.3) THEN
  441.              IF (ISUP2.EQ.4) THEN
  442.                CALL ERREUR(609)
  443.                GOTO 9990
  444.              ELSE IF (ISUP2.EQ.5) THEN
  445.                IPTVPR = MCHAM2.IELVAL(1)
  446.              ELSE IF (ISUP2.EQ.1.OR.ISUP2.EQ.2) THEN
  447.                IVPRES = MCHAM2.IELVAL(1)
  448.                CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  449.              ENDIF
  450.            ELSE
  451.              IPTVPR = MCHAM2.IELVAL(1)
  452.            ENDIF
  453.          ENDIF
  454. C
  455. C        INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  456. C
  457.          N1=1
  458.          L1=6
  459.          N3=6
  460.          SEGINI MCHELM
  461.          TITCHE='FORCES'
  462.          IFOCHE=IFOUR
  463.          IPCHEL=MCHELM
  464. C
  465.          IMACHE(1)=IPOGEO
  466.          INFCHE(1,1)=0
  467.          INFCHE(1,2)=0
  468.          INFCHE(1,3)=NHRM
  469.          INFCHE(1,4)=IPTINT
  470.          INFCHE(1,5)=0
  471.          INFCHE(1,6)=3
  472. C
  473. C        RECHERCHE DE LA TAILLE DES MELVALS
  474. C
  475.          MELEME=IPOGEO
  476.          N1PTEL=NUM(/1)
  477.          N1EL  =NUM(/2)
  478.          N2PTEL=0
  479.          N2EL  =0
  480. C
  481. C        CREATION DU MCHAML DE LA SOUS ZONE
  482. C
  483.          N2=NCOMP
  484.          SEGINI MCHAML
  485.          ICHAML(1)=MCHAML
  486.          NSR=1
  487.          NCOSOR=NCOMP
  488.          SEGINI MPTVAL
  489.          IVAFOR=MPTVAL
  490.          nomid = MOFORC
  491.  
  492.          DO ICOMP=1,NCOMP
  493.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  494.             TYPCHE(ICOMP)='REAL*8'
  495.             SEGINI MELVAL
  496.             IELVAL(ICOMP)=MELVAL
  497.             IVAL(ICOMP)=MELVAL
  498.          ENDDO
  499. C____________________________________________________________________
  500. C
  501. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  502. C____________________________________________________________________
  503.           IF (MOCARA.NE.0) THEN
  504.             IVACA1 = IVACAR
  505.             IF (ISUPCA.EQ.1) THEN
  506.               CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYR8,0,
  507.      &                                       INFOS,3,IVACA1)
  508.               IF (IERR.NE.0) GOTO 9900
  509.               CALL VALCHE(IVACA1,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  510.               IF (IERR.NE.0) THEN
  511.                 ISUPCA = 0
  512.                 GOTO 9990
  513.               ENDIF
  514.             ENDIF
  515.           ENDIF
  516. C
  517. C        CALCUL DES FORCES NODALES EQUIVALENTES
  518. C        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  519. C
  520. C           CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS
  521. C           FACES ASSOCIEES SEG2 OU SEG3
  522. C
  523.          IF (MELE.EQ.2.OR.MELE.EQ.3) THEN
  524.             CALL FPMA2D(IPTVPR,IPOGEO,ipt1,IPTINT,IVAFOR,IVACA1,XP
  525.      +                   ,netn1,ietn1)
  526. C
  527. C           CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS
  528. C           FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8
  529. C
  530.          ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.
  531.      +                                   OR.MELE.EQ.34)THEN
  532.             CALL FPMA3D(IPTVPR,IPOGEO,ipt1,IPTINT,IVAFOR,XP
  533.      +                  ,netn1,ietn1)
  534. C
  535. C= Cas des elements MASSIFs UNIDIMENSIONNELs (1D)
  536. C= Face associee : POI1 (numero 45)
  537.          ELSE IF (MELE.EQ.45) THEN
  538.             CALL FPMA1D(IPTVPR,IPOGEO,ipt1,IPTINT,IVAFOR,XP
  539.      +                  ,netn1,ietn1)
  540. C
  541. C           ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  542. C
  543.          ELSE
  544.             MOTERR(1:4)=NOMTP(MELE)
  545.             MOTERR(5:12)='FPMASS'
  546.             CALL ERREUR (86)
  547.             GOTO 9990
  548.          ENDIF
  549. C
  550. C        ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  551. C        ET ON ADDITIONNE LES CHAM/POIN ELEMENTAIRES
  552. C
  553.          CALL CHAMPO(IPCHEL,0,IPCHPO,IPPT)
  554.          CALL DTCHAM(IPCHEL)
  555.          IF (IPPT.EQ.0) THEN
  556.             GOTO 9990
  557.          ENDIF
  558.          IF ((ISOUS-IRRT).GT.1.OR.IB.GT.1) THEN
  559.             CALL ADCHPO(IPCHPO,IPTFP,IPPT,1D0,1D0)
  560. C            CALL ECRCHA(MOGEOM)
  561.             CALL DTCHPO(IPCHPO)
  562. C            CALL ECRCHA(MOGEOM)
  563.             CALL DTCHPO(IPTFP)
  564.             IF (IPPT.EQ.0) GOTO 9990
  565.             IPTFP=IPPT
  566.          ELSE
  567.             IPTFP=IPCHPO
  568.          ENDIF
  569.  
  570.           ISOK = 1
  571.  
  572.  9990     CONTINUE
  573.           mptval = IVAFOR
  574.           IF (IVAFOR.NE.0) SEGSUP,mptval
  575.           nomid = MOFORC
  576.           if (MOFORC.NE.0 .and. lsupfo) SEGSUP,nomid
  577.           IF (IVACA1.NE.0 .AND. ISUPCA.EQ.1) THEN
  578.             CALL DTMVAL(IVACA1,3)
  579.           ENDIF
  580.           IF (IPMOD1.NE.0) CALL DTMODL(IPMOD1)
  581.           IF (ISOK.EQ.0) GOTO 9900
  582.  
  583.  110    CONTINUE
  584. C- Fin de la boucle sur les sous zones de l'enveloppe
  585.  
  586.  9900   CONTINUE
  587.         nomid = MOCARA
  588.         IF (MOCARA.NE.0) SEGSUP,nomid
  589.         IF (IVACAR.NE.0) CALL DTMVAL(IVACAR,1)
  590.         IF (ISOK.EQ.0) GOTO 9000
  591.  
  592.  100  CONTINUE
  593.  
  594.       IF (IRRT.EQ.NSOUS) THEN
  595.          IRET = 0
  596.          CALL ERREUR(395)
  597.       ELSE
  598.          IRET = 1
  599.       ENDIF
  600.  
  601.  9000 CONTINUE
  602.       notype = MOTYR8
  603.       SEGSUP,notype
  604.       if (netn.ne.0) SEGSUP,netn
  605.       if (ietn.ne.0) SEGSUP,ietn
  606.  
  607.       RETURN
  608.       END
  609.  
  610.  
  611.  

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