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    CB215821  24/04/12    21:16:02     11897          
  2.       SUBROUTINE FPMASS(IPCHE1,IPCHM1,IPMODL,IPTFP,JPMAIL,XP,IRET)
  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. C
  33.       IMPLICIT INTEGER(I-N)
  34.       IMPLICIT REAL*8(A-H,O-Z)
  35.       INTEGER ISUP
  36. C
  37.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC CCHAMP
  41. -INC SMCOORD
  42. -INC SMELEME
  43. -INC SMMODEL
  44. -INC SMCHAML
  45. -INC SMCHPOI
  46. -INC SMINTE
  47. -INC CCREEL
  48. C
  49.       SEGMENT INFO
  50.        INTEGER INFELL(JG)
  51.       ENDSEGMENT
  52. C
  53.       SEGMENT NOTYPE
  54.         CHARACTER*16 TYPE(NBTYPE)
  55.       ENDSEGMENT
  56. C
  57.       SEGMENT MPTVAL
  58.         INTEGER IPOS(NS)    ,NSOF(NS)
  59.         INTEGER      IVAL(NCOSOU)
  60.         CHARACTER*16 TYVAL(NCOSOU)
  61.       ENDSEGMENT
  62. C
  63.       segment netn(nbpts+1)
  64.       segment ietn(letn)
  65. C
  66.  
  67.       DIMENSION V(3),F(3)
  68.       CHARACTER*4 MOSTRI,MOAPPU,MOGEOM
  69.       CHARACTER*(NCONCH) CONM
  70.       PARAMETER (NINF=3)
  71.       INTEGER INFOS(NINF)
  72.       LOGICAL LSUPFO,ltelq
  73.       CHARACTER*8 MOFO
  74. C
  75.       DATA MOAPPU/'APPU'/,MOSTRI/'STRI'/
  76.       DATA MOGEOM/'GEOM'/
  77. C
  78.       ISUP = 0
  79.       IRET = 0
  80.       IGEOM = 0
  81. C
  82.       IND=0
  83.       IPCHE2=0
  84.       NHRM=NIFOUR
  85.       IPTVPR=0
  86. C
  87. C     CAS OU UN CHPOP EST FOURNI
  88. C     ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  89. C
  90.       IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  91.         MCHPOI=IPCHE1
  92.         DO 50 I=1,IPCHP(/1)
  93.            MSOUPO=IPCHP(I)
  94.            IF (I.GT.1) THEN
  95.               ltelq=.false.
  96.               CALL FUSE(IGEOM,IGEOC,IPPT,ltelq)
  97.               IGEOM=IPPT
  98.            ELSE
  99.               IGEOM=IGEOC
  100.            ENDIF
  101.  50     CONTINUE
  102.         IF (IERR.NE.0) RETURN
  103.       ENDIF
  104. C
  105. C     CAS OU UN CHAMELEM EST FOURNI
  106. C     ON CREE L OBJET GEOMETRIQUE CONTENANT TOUS LES PTS SI BESOIN
  107. C
  108.       IF(IPCHM1.NE.0) THEN
  109.         MCHEL2 = IPCHM1
  110.         DO 60 I=1,MCHEL2.IMACHE(/1)
  111.           IMTMP=MCHEL2.IMACHE(I)
  112.           IF (I.GT.1) THEN
  113.             ltelq=.false.
  114.             CALL FUSE(IGEOM,IMTMP,IPPT,ltelq)
  115.             IGEOM=IPPT
  116.           ELSE
  117.             IGEOM=IMTMP
  118.           ENDIF
  119.  60     CONTINUE
  120.         IF (IERR.NE.0) RETURN
  121.       ENDIF
  122. C
  123. C     ACTIVATION DU MODEL
  124. C
  125.       MMODEL=IPMODL
  126.       NSOUS=KMODEL(/1)
  127.  
  128.       idimp1=IDIM+1
  129. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  130.       IF (IFOUR.EQ.-3) THEN
  131.         NDPGE=3
  132.       ELSE IF (IFOUR.EQ.11) THEN
  133.         NDPGE=2
  134.       ELSE IF (IFOUR.EQ. 7.OR.IFOUR.EQ. 8.OR.IFOUR.EQ. 9.OR.
  135.      .         IFOUR.EQ.10.OR.IFOUR.EQ.14) THEN
  136.         NDPGE=1
  137.       ELSE
  138.         NDPGE=0
  139.       ENDIF
  140.  
  141.       IRRT=0
  142.       DO 100 ISOUS=1,NSOUS
  143. C
  144. C        ON RECUPERE L INFORMATION GENERALE
  145. C
  146.          IMODEL=KMODEL(ISOUS)
  147.          IPMAIL=IMAMOD
  148.          CONM  =CONMOD
  149. C
  150. C        TRAITEMENT DU MODEL
  151. C
  152.          MOCARA = 0
  153.          IVACAR = 0
  154.          IVAFOR = 0
  155. C
  156.          MELM=NEFMOD
  157. C         write(*,*) ISOUS,'/',NSOUS,' : ',IMODEL,'NEFMOD=',MELM
  158.          if ((melm . eq . 22).OR.(melm . eq . 259)) then
  159. C      ... Ici sous modele de multiplicateur de lagrange on
  160. C          incrémente le compteur et on passe à la zone suivante ...
  161.             IRRT=IRRT+1
  162.             go to 100
  163.          endif
  164. C
  165. C        ON RECUPERE LES ELTS DE L ENVELOPPE DU MASSIF APPUYES
  166. C        STRICTEMENT SUR LE CHPOINT DE PRESSIONS OU appartenant au
  167. C        MAILLAGE DONNE
  168. C
  169.          CALL ECROBJ('MAILLAGE',IPMAIL)
  170.          IF (IDIM.EQ.2) THEN
  171.            CALL PRCONT
  172.          ELSE IF (IDIM.EQ.3) THEN
  173.            CALL ENVELO
  174.          ELSE IF (IDIM.EQ.1) THEN
  175.            CALL PREX1D
  176.          ENDIF
  177.          IF (IERR.NE.0) RETURN
  178.          CALL LIROBJ('MAILLAGE',ienvel,1,IRETOU)
  179.          IF (IERR .NE. 0) RETURN
  180.          CALL ACTOBJ('MAILLAGE',ienvel,1)
  181. C     ... si un CHPOINT a été donné, on va chercher la partie de
  182. C         l'enveloppe s'appuyant strictement sur le support du CHPOINT ...
  183.            IF(JPMAIL.EQ.0) THEN
  184.               CALL ECROBJ('MAILLAGE',IGEOM)
  185.               CALL ECRCHA(MOSTRI)
  186.               CALL ECRCHA(MOAPPU)
  187.               CALL ECROBJ('MAILLAGE',ienvel)
  188.               CALL EXTREL (IRR,0,IBNOR)
  189.            ELSE
  190. C      ... sinon, on va chercher l'intersection de l'enveloppe avec
  191. C          le maillage fourni ...
  192.               CALL INTERB(ienvel,jpmail,irr,IPOGEO)
  193.            ENDIF
  194. C      ... Ici on teste si intersection est vide, si OUI on
  195. C          incrémente le compteur et on passe à la zone suivante ...
  196.            IF (irr.gt.0) THEN
  197.               IRRT=IRRT+1
  198.               GOTO 100
  199.            ENDIF
  200.            IF(JPMAIL.EQ.0) THEN
  201.              CALL LIROBJ('MAILLAGE',IPOGEO,1,iret)
  202.              IF (IERR.NE.0) RETURN
  203.              CALL ACTOBJ('MAILLAGE',IPOGEO,1)
  204.            ENDIF
  205. C
  206. C     ON DETERMINE LA FORMULATION ASSOCIEE A L OBJET
  207. C     GEOMETRIQUE ELEMENTAIRE DE SURFACE
  208. C
  209.       IPT3=IPOGEO
  210.       IPT2=IPT3
  211.       IB=0
  212. C
  213. C     BOUCLE SUR LES SOUS ZONES DE L ENVELOPPE
  214. C
  215.       DO 110 IB=1,MAX(1,IPT3.LISOUS(/1))
  216.          IF (IPT3.LISOUS(/1).NE.0) THEN
  217.             IPT2=IPT3.LISOUS(IB)
  218.             IPOGEO=IPT2
  219.          ENDIF
  220.          NBNN =IPT2.NUM(/1)
  221.          LETYP=IPT2.ITYPEL
  222.          IF (IPT3.LISOUS(/1).EQ.0) GOTO 112
  223. C
  224.  112     CONTINUE
  225. C
  226. C        PETIT TEST SUR LE TYPE
  227. C
  228.          IF(LETYP.EQ.1.AND.IDIM.NE.1) THEN
  229.             CALL ERREUR(16)
  230.             GOTO 9997
  231.          ENDIF
  232. C
  233.          CALL TYPFAC(MELM,NBNN,MELE)
  234. C          write(*,*) 'TYPFAC --> MELE=',MELE
  235.          IF (MELE.EQ.0) THEN
  236. C
  237. C        ERREUR : IMPOSSIBLE D UTILISER L OPERATEUR PRESSI POUR
  238. C                 LES ELEMENTS DE FORMULATION MELM
  239. C
  240.             MOTERR(1:8)=NOMTP(MELM)
  241.             CALL ERREUR(193)
  242.             GOTO 9997
  243.          ENDIF
  244. C
  245. C        CAS OU UN CHAMP PAR POINT A ETE FOURNI
  246. C        ON CREE L OBJET MODEL ASSOCIE A LA SURFACE ELEMENTAIRE
  247. C
  248.          IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) THEN
  249.            N1=1
  250.            SEGINI MMODE1
  251.            IPMOD1=MMODE1
  252.            NFOR=FORMOD(/2)
  253.            NMAT=MATMOD(/2)
  254.            MN3=0
  255.            NPARMO=0
  256.            nobmod=0
  257.            SEGINI IMODE1
  258.            MMODE1.KMODEL(1)=IMODE1
  259.            IMODE1.IMAMOD=IPOGEO
  260.            IMODE1.NEFMOD=MELE
  261.            IMODE1.CONMOD=CONMOD
  262.            DO 10 I=1,NFOR
  263.               IMODE1.FORMOD(I)=FORMOD(I)
  264.  10        CONTINUE
  265.            DO 11 I=1,NMAT
  266.               IMODE1.MATMOD(I)=MATMOD(I)
  267.  11        CONTINUE
  268. C
  269. C            ON TRANSFORME LE CHPOINT DE PRESSION EN CHELEM ELEMENTAIRE
  270. C
  271.              CALL CHAME1(0,IPMOD1,IPCHE1,' ',ICHELP,3)
  272.              IF (IERR.NE.0) THEN
  273.                CALL DTMODL(IPMOD1)
  274.                RETURN
  275.              ENDIF
  276.              MCHEL1=ICHELP
  277.              MCHAM1=MCHEL1.ICHAML(1)
  278.              IPTVPR=MCHAM1.IELVAL(1)
  279.          ENDIF
  280. C
  281. C        INFORMATION SUR L'ELEMENT FINI
  282. C
  283.          CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  284. Cbp : on aurait voulu faire CALL ELQUOI(MELE,0,3,IPINF,IMODE1),
  285. C   : mais cela ne marche evidemment pas bien...
  286.          IF (IERR.NE.0) THEN
  287.             IF(IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  288.             GOTO 9997
  289. C            RETURN
  290.          ENDIF
  291.          INFO=IPINF
  292.          IPTINT=INFELL(11)
  293.          MFR   =INFELL(13)
  294. C*OF En DIMEnsion 1, on force FORMULATION MASSIVE pour POI1
  295.          IF (IDIM.EQ.1.AND.MELE.EQ.45) MFR=1
  296.          IPPORE=0
  297.          IF(MFR.EQ.33) IPPORE=NBNN
  298. C Destruction immediate du segment
  299.          SEGSUP,INFO
  300. C Caracteristiques d'integration
  301.          MINTE=IPTINT
  302. C
  303. C        CAS OU UN CHAMP PAR ELEMENT A ETE FOURNI
  304. C        -> Verification de son support
  305. C
  306.          IF (IPCHM1.NE.0) THEN
  307.            CALL QUESUP(0,IPCHM1,0,0,ISUP1,ISUP2)
  308.            MCHEL2=IPCHM1
  309.            MCHAM2 = MCHEL2.ICHAML(1)
  310.            IF (ISUP2.NE.3) THEN
  311.              IF (ISUP2.EQ.4) THEN
  312.                CALL ERREUR(609)
  313.                GOTO 9997
  314.              ELSE IF (ISUP2.EQ.5) THEN
  315.                IPTVPR = MCHAM2.IELVAL(1)
  316.              ELSE IF (ISUP2.EQ.1.OR.ISUP2.EQ.2) THEN
  317.                IVPRES = MCHAM2.IELVAL(1)
  318.                CALL VALMEL(IVPRES,IPTINT,IPTVPR)
  319.              ENDIF
  320.            ELSE
  321.              IPTVPR = MCHAM2.IELVAL(1)
  322.            ENDIF
  323.          ENDIF
  324. C
  325. C        INITIALISATION DU CHELEM ELEMENTAIRE DES FORCES NODALES
  326. C
  327.          N1=1
  328.          L1=6
  329.          N3=5
  330.          SEGINI MCHELM
  331.          TITCHE='FORCES'
  332.          IFOCHE=IFOUR
  333.          IPCHEL=MCHELM
  334. C
  335.          IMACHE(1)=IPOGEO
  336.          INFCHE(1,1)=0
  337.          INFCHE(1,2)=0
  338.          INFCHE(1,3)=NHRM
  339.          INFCHE(1,4)=IPTINT
  340.          INFCHE(1,5)=0
  341. C
  342. C        RECHERCHE DE LA TAILLE DES MELVALS
  343. C
  344.          MELEME=IPOGEO
  345.          N1PTEL=NUM(/1)
  346.          N1EL  =NUM(/2)
  347.          N2PTEL=0
  348.          N2EL  =0
  349. C
  350. C        RECHERCHE DES NOM DE COMPOSANTES
  351. C
  352.         if(lnomid(2).ne.0) then
  353.           nomid=lnomid(2)
  354.           moforc=nomid
  355.           nfor=lesobl(/2)
  356.           nfac=0
  357.           lsupfo=.false.
  358. C           write(*,*) 'nomid deja existant dans IMODEL',IMODEL
  359.         else
  360.          lsupfo=.true.
  361.          CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC)
  362. C           write(*,*) 'appel a IDFORC pour creer nomid'
  363.         endif
  364.          NCOMP=NFOR-NDPGE
  365. C**      IF (IFOUR.EQ.-3) NCOMP=NFOR-3
  366. C
  367. C        CREATION DU MCHAML DE LA SOUS ZONE
  368. C
  369.          N2=NCOMP
  370.          SEGINI MCHAML
  371.          ICHAML(1)=MCHAML
  372.          NS=1
  373.          NCOSOU=NCOMP
  374.          SEGINI MPTVAL
  375.          IVAFOR=MPTVAL
  376.          NOMID=MOFORC
  377.  
  378. Cbp      on verifie qu on a suffisamment de composantes d'effort
  379.          NFO=0
  380.          IF(MELE.EQ.2.OR.MELE.EQ.3) NFO=2
  381.          IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.OR.MELE.EQ.34) NFO=3
  382.          IF(MELE.EQ.45) NFO=1
  383. C          IF(NFO.eq.0) --> erreur + tard
  384.          IF(NFO.ne.0) THEN
  385.            IF(NCOMP.lt.NFO) GOTO 444
  386.            DO 44 ICOMP=1,NFO
  387.               MOFO=LESOBL(ICOMP)
  388.               IF(MOFO(1:1).NE.'F') GOTO 444
  389.  44        CONTINUE
  390. C          pas d'erreur ?
  391.            GOTO 440
  392. C         -erreur
  393.  444       CONTINUE
  394.            WRITE(IOIMP,*) 'on attend un MODELE avec au moins',NFO,
  395.      &    'composantes de FORCES !'
  396.            write(IOIMP,*) 'Ici, on a :',(LESOBL(iou),iou=1,NCOMP)
  397.            MOTERR(1:16)='MECANIQUE, ...  '
  398.            CALL ERREUR(719)
  399.            IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  400.            GOTO 9990
  401. C         -pas d'erreur
  402.  440       CONTINUE
  403.          ENDIF
  404.  
  405.          DO 4 ICOMP=1,NCOMP
  406.             NOMCHE(ICOMP)=LESOBL(ICOMP)
  407.             TYPCHE(ICOMP)='REAL*8'
  408.             SEGINI MELVAL
  409.             IELVAL(ICOMP)=MELVAL
  410.             IVAL(ICOMP)=MELVAL
  411.  4       CONTINUE
  412. C
  413. C____________________________________________________________________
  414. C
  415. C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES
  416. C____________________________________________________________________
  417. C
  418.          IF (IFOUR.EQ.-2.AND.IND.EQ.0) THEN
  419.            CALL LIROBJ('MCHAML  ',IPCHE2,0,IRT3)
  420.            IND=1
  421.            IF (IERR.NE.0) GOTO 9990
  422.            IF(IRT3 .EQ. 1) CALL ACTOBJ('MCHAML  ',IPCHE2,1)
  423.            IF (IPCHE2.NE.0) THEN
  424. C
  425. C   Verification du lieu support du MCHAML de caracteristique
  426. C
  427.              CALL QUESUP(IPMODL,IPCHE2,3,1,ISUP,IRETCA)
  428.              IF (ISUP.GT.1) GOTO 9990
  429. C
  430. C        CREATION DU TABLEAU INFOS
  431. C
  432.              CALL IDENT (IPMAIL,CONM,IPCHE2,0,INFOS,IRTD)
  433.              IF (IRTD.EQ.0) THEN
  434.                 SEGSUP MCHELM
  435.                 CALL DTCHAM(IPCHE2)
  436.                 RETURN
  437.              ENDIF
  438. C
  439.              NBROBL=0
  440.              NBRFAC=1
  441.              SEGINI NOMID
  442.              MOCARA=NOMID
  443.              LESFAC(1)='DIM3'
  444. C
  445.              NBTYPE=1
  446.              SEGINI NOTYPE
  447.              MOTYPE=NOTYPE
  448.              TYPE(1)='REAL*8'
  449. C
  450.              CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOCARA,MOTYPE,0,
  451.      +                                       INFOS,3,IVACAR)
  452.              SEGSUP NOTYPE
  453.              IF (IERR.NE.0) GOTO 9990
  454.              NCARA=NBROBL
  455.              NCARF=NBRFAC
  456.              NCARR=NCARA+NCARF
  457. C
  458.              IF (ISUP.EQ.1) THEN
  459.                CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  460.              ENDIF
  461. C
  462.            ENDIF
  463.          ENDIF
  464. C
  465. C        CALCUL DES FORCES NODALES EQUIVALENTES
  466. C        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  467. C
  468.          IF (MELE.EQ.2.OR.MELE.EQ.3) THEN
  469. C
  470. C           CAS DES ELEMENTS MASSIFS BIDIMENSIONNELS
  471. C           FACES ASSOCIEES SEG2 OU SEG3
  472. C
  473.             CALL FPMA2D(IPTVPR,IPOGEO,IPTINT,IVAFOR,IVACAR,XP)
  474. C
  475.          ELSE IF(MELE.EQ.31.OR.MELE.EQ.32.OR.MELE.EQ.33.
  476.      +                                   OR.MELE.EQ.34)THEN
  477. C
  478. C           CAS DES ELEMENTS MASSIFS TRIDIMENSIONNELS
  479. C           FACES ASSOCIEES FAC3,FAC4,FAC6 OU FAC8
  480. C
  481.             CALL FPMA3D(IPTVPR,IPOGEO,IPTINT,IVAFOR,XP)
  482. C
  483. C= Cas des elements MASSIFs UNIDIMENSIONNELs (1D)
  484. C= Face associee : POI1 (numero 45)
  485.          ELSE IF (MELE.EQ.45) THEN
  486.             CALL FPMA1D(IPTVPR,IPOGEO,IPTINT,IVAFOR,XP)
  487.  
  488.          ELSE
  489. C
  490. C           ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  491. C
  492.             MOTERR(1:4)=NOMTP(MELE)
  493.             MOTERR(5:12)='FPMASS'
  494.             CALL ERREUR (86)
  495.             IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  496.             GOTO 9990
  497.          ENDIF
  498. C
  499. C        POUR CHAQUE ELEMENT,
  500. C        ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF
  501. C        A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSI
  502. C
  503. C   prob optimiseur il faut initialiser melva1
  504.          MELVA1=IPMODL
  505.          IF(IPTVPR.NE.0) THEN
  506.            MELVA1=IPTVPR
  507.          ENDIF
  508.          MELEME=IPOGEO
  509.          IPT1=IPMAIL
  510. C
  511. C  pour accelerer la recherche, utilisation d'un tableau des elements touchant un noeud.
  512.          segact mcoord
  513.          segini netn
  514.          do 1050 j=1,ipt1.num(/2)
  515.           do 1050 i=1,ipt1.num(/1)
  516.            netn(ipt1.num(i,j))=netn(ipt1.num(i,j))+1
  517.  1050    continue
  518.          do 1060 i=2,netn(/1)
  519.             netn(i)=netn(i)+netn(i-1)
  520.  1060    continue
  521.          letn=netn(netn(/1))
  522.          segini ietn
  523.          do 1070 j=1,ipt1.num(/2)
  524.           do 1070 i=1,ipt1.num(/1)
  525.            ietn(netn(ipt1.num(i,j)))=j
  526.            netn(ipt1.num(i,j))=netn(ipt1.num(i,j))-1
  527.  1070     continue
  528.  
  529.          DO 150 IEF=1,NUM(/2)
  530.            do 160 inf=1,num(/1)
  531.              ip=num(inf,ief)
  532.               id=netn(ip)+1
  533.               if=netn(ip+1)
  534.              do 165 itn=id,if
  535.               iem=ietn(itn)
  536.                jne=0
  537.                do 166 i0=1,num(/1)
  538.                do 166 i1=1,ipt1.num(/1)
  539.                 if (num(i0,ief).eq.ipt1.num(i1,iem)) jne=jne+1
  540.  166           continue
  541.                if (jne.eq.num(/1)) goto 170
  542.  165         continue
  543.  160       continue
  544.             CALL ERREUR(26)
  545.             IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  546.             GOTO 9990
  547.  170        CONTINUE
  548.             NBM=IPT1.NUM(/1)
  549.             NBMA1=NUM(/1)
  550.             IF (IDIM.EQ.3) THEN
  551.               XG=0.D0
  552.               YG=0.D0
  553.               ZG=0.D0
  554.               DO INM=1,NBM
  555.                 IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  556.                 XG=XG+XCOOR(IREFM+1)
  557.                 YG=YG+XCOOR(IREFM+2)
  558.                 ZG=ZG+XCOOR(IREFM+3)
  559.               ENDDO
  560.               XG=XG/NBM
  561.               YG=YG/NBM
  562.               ZG=ZG/NBM
  563.               XK=0.D0
  564.               YK=0.D0
  565.               ZK=0.D0
  566.               DO INF=1,NBMA1
  567.                 IREFF=(NUM(INF,IEF)-1)*idimp1
  568.                 XK=XK+XCOOR(IREFF+1)
  569.                 YK=YK+XCOOR(IREFF+2)
  570.                 ZK=ZK+XCOOR(IREFF+3)
  571.               ENDDO
  572.               XK=XK/NBMA1
  573.               YK=YK/NBMA1
  574.               ZK=ZK/NBMA1
  575.               V(1)=XG-XK
  576.               V(2)=YG-YK
  577.               V(3)=ZG-ZK
  578.               VN=SQRT(V(1)**2+V(2)**2+V(3)**2)
  579.               V(1)=V(1)/VN
  580.               V(2)=V(2)/VN
  581.               V(3)=V(3)/VN
  582.             ELSE IF (IDIM.EQ.2) THEN
  583.               XG=0.D0
  584.               YG=0.D0
  585.               DO INM=1,NBM
  586.                 IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  587.                 XG=XG+XCOOR(IREFM+1)
  588.                 YG=YG+XCOOR(IREFM+2)
  589.               ENDDO
  590.               XG=XG/NBM
  591.               YG=YG/NBM
  592.               XK=0.D0
  593.               YK=0.D0
  594.               DO INF=1,NBMA1
  595.                 IREFF=(NUM(INF,IEF)-1)*idimp1
  596.                 XK=XK+XCOOR(IREFF+1)
  597.                 YK=YK+XCOOR(IREFF+2)
  598.               ENDDO
  599.               XK=XK/NBMA1
  600.               YK=YK/NBMA1
  601.               V(1)=XG-XK
  602.               V(2)=YG-YK
  603.               VN=SQRT(V(1)**2+V(2)**2)
  604.               V(1)=V(1)/VN
  605.               V(2)=V(2)/VN
  606.             ELSE IF (IDIM.EQ.1) THEN
  607.               XG=0.D0
  608.               DO INM=1,NBM
  609.                 IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
  610.                 XG=XG+XCOOR(IREFM+1)
  611.               ENDDO
  612.               XG=XG/NBM
  613.               XK=0.D0
  614.               DO INF=1,NBMA1
  615.                 IREFF=(NUM(INF,IEF)-1)*idimp1
  616.                 XK=XK+XCOOR(IREFF+1)
  617.               ENDDO
  618.               XK=XK/NBMA1
  619.               V(1)=XG-XK
  620.               VN=ABS(V(1))
  621.               V(1)=V(1)/VN
  622.             ENDIF
  623. C
  624. C           ET ON ORIENTE LES FORCES NODALES APPLIQUEES SUR L ELEMENT
  625. C  EN COMPARANT LES DIRECTIONS DE LA RESULTANTE DES FORCES ET DU VECTEUR
  626. C  PUIS ON MULTIPLIE PAR LE SIGNE DE LA PRESSION
  627. C
  628.             F(1)=0.D0
  629.             F(2)=0.D0
  630.             F(3)=0.D0
  631.             MPTVAL=IVAFOR
  632.             DO 200 INF=1,N1PTEL
  633.                DO 201 J=1,IDIM
  634.                   MELVAL=IVAL(J)
  635.                   F(J)=F(J)+VELCHE(INF,IEF)
  636.  201           CONTINUE
  637.  200        CONTINUE
  638.             FN2=0.D0
  639.             TEST=0.D0
  640.             DO 210 J=1,IDIM
  641.                FN2=FN2 + F(J)**2
  642.                TEST=TEST+ V(J)*F(J)
  643.  210        CONTINUE
  644.             FN=SQRT(FN2)
  645. C
  646. C           ERREUR    IMPOSSIBLE D ORIENTER LES FORCES DE PRESSION
  647. C
  648.             IF (ABS(TEST).LE.0.001D0*FN .AND.
  649.      &           FN.NE.0.D0) THEN
  650.                CALL ERREUR(192)
  651.                IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0)  CALL DTMODL(IPMOD1)
  652.                GOTO 9990
  653.             ENDIF
  654.             XFLOT=1.D0
  655.             IF (TEST.LT.0.D0) XFLOT=-1.D0
  656.             IF(IPTVPR.NE.0) THEN
  657.               SP = SIGN(1.D0,MELVA1.VELCHE(1,IEF))
  658.             ELSE
  659.               SP = SIGN(1.D0,XP)
  660.             ENDIF
  661.             MPTVAL=IVAFOR
  662.             DO 220 INF=1,N1PTEL
  663.                DO 220 ICOMP=1,NCOMP
  664.                   MELVAL=IVAL(ICOMP)
  665.                   VELCHE(INF,IEF)=VELCHE(INF,IEF)*XFLOT*SP
  666.  220        CONTINUE
  667.  150     CONTINUE
  668.          segsup netn,ietn
  669. C
  670. C        ON TRANSFORME LE CHAM/ELEM EN CHAM/POIN
  671. C        ET ON ADDITIONNE LES CHAM/POIN ELEMENTAIRES
  672. C
  673.          CALL CHAMPO(IPCHEL,0,IPCHPO,IPPT)
  674.          CALL DTCHAM(IPCHEL)
  675.          IF (IPPT.EQ.0) THEN
  676.            IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL (IPMOD1)
  677.             GOTO 9990
  678.          ENDIF
  679.          IF ((ISOUS-IRRT).GT.1.OR.IB.GT.1) THEN
  680.             CALL ADCHPO(IPCHPO,IPTFP,IPPT,1D0,1D0)
  681. C            CALL ECRCHA(MOGEOM)
  682.             CALL DTCHPO(IPCHPO)
  683. C            CALL ECRCHA(MOGEOM)
  684.             CALL DTCHPO(IPTFP)
  685.             IF (IPPT.EQ.0) THEN
  686.               IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  687.                GOTO 9990
  688.             ENDIF
  689.             IPTFP=IPPT
  690.          ELSE
  691.             IPTFP=IPCHPO
  692.          ENDIF
  693.          IF(JPMAIL.EQ.0.AND.IPCHM1.EQ.0) CALL DTMODL(IPMOD1)
  694.  110  CONTINUE
  695.       NOMID=MOFORC
  696.       if(lsupfo)SEGSUP NOMID
  697. C
  698.       IF(ISUP.EQ.1.AND.IPCHE2.NE.0)THEN
  699.            CALL DTMVAL(IVACAR,3)
  700.       ELSE
  701.           CALL DTMVAL(IVACAR,1)
  702.       ENDIF
  703.       NOMID=MOCARA
  704.       IF (MOCARA.NE.0) SEGSUP NOMID
  705. C
  706.       MPTVAL=IVAFOR
  707.       SEGSUP MPTVAL
  708. C
  709.  100  CONTINUE
  710.       IF(IRRT.EQ.KMODEL(/1)) THEN
  711.          CALL ERREUR(395)
  712.       ELSE
  713.         IRET = 1
  714.       ENDIF
  715.       RETURN
  716. C
  717.  9990 CONTINUE
  718. C
  719. C     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  720. C
  721.       CALL DTMVAL(IVAFOR,3)
  722. C
  723.       IF(ISUP.EQ.1.AND.IPCHE2.NE.0)THEN
  724.            CALL DTMVAL(IVACAR,3)
  725.       ELSE
  726.           CALL DTMVAL(IVACAR,1)
  727.       ENDIF
  728.       NOMID=MOCARA
  729.       IF (MOCARA.NE.0) SEGSUP NOMID
  730. C
  731.       SEGSUP MCHAML
  732.       SEGSUP MCHELM
  733. C
  734.       NOMID=MOFORC
  735.       if(lsupfo)SEGSUP NOMID
  736.  
  737.  9997 CONTINUE
  738.  
  739.       IRET = 0
  740.  
  741.       END
  742.  
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  

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