Télécharger la plaquette Cast3M


fr en

Télécharger fsurco.eso

Retour à la liste

Numérotation des lignes : 

fsurco

  1. C FSURCO    SOURCE    OF166741  25/02/21    21:17:07     12166          
  2.  
  3.        SUBROUTINE FSURCO(IPMODL,IPCHPS,IPVECT,IPCARA, IPTFP)
  4.  
  5. *_____________________________________________________________________
  6. *
  7. *   CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES COQUES
  8. *
  9. *   ENTREES :
  10. *   ---------
  11. *
  12. *    IPMODL   OBJET AFFECTE SUR LEQUEL S APPLIQUE LA PRESSION
  13. *    IPCHE1   CHPOINT CONTENANT LES VALEURS DES FORCES AUX NOEUDS
  14. *    IPVECT   VECTEUR INDIQUANT LA DIRECTION DANS LAQUELLE
  15. *             S APPLIQUE LA FORCE SURFACIQUE
  16. *
  17. *   SORTIES :
  18. *   ---------
  19. *
  20. *    IPTFP    CHPOINT DES FORCES NODALES EQUIVALENTES
  21. *
  22. *_____________________________________________________________________
  23. *
  24.       IMPLICIT INTEGER(I-N)
  25.       IMPLICIT REAL*8(A-H,O-Z)
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCHAMP
  30.  
  31. -INC SMCOORD
  32. -INC SMELEME
  33. -INC SMMODEL
  34. -INC SMCHAML
  35. -INC SMCHPOI
  36. -INC SMINTE
  37.  
  38. -INC TMPTVAL
  39.  
  40.       SEGMENT NOTYPE
  41.         CHARACTER*16 TYPE(NBTYPE)
  42.       ENDSEGMENT
  43.  
  44.       PARAMETER (NINF=3)
  45.       INTEGER INFOS(NINF)
  46.  
  47.       DIMENSION V(3),ipt(3)
  48.       CHARACTER*(LOCOMP) mfors(3)
  49.       CHARACTER*(NCONCH) CONM
  50.  
  51. C=  LEFCOQ   Liste des numeros d'elements finis COQUEs
  52. C=  NEFCOQ   Longueur de cette liste
  53.       PARAMETER ( NEFCOQ = 8 )
  54.       DIMENSION LEFCOQ(NEFCOQ)
  55. C ============
  56. C  Elements COQUEs  COQ2 COQ3 COQ6 COQ4 COQ8  DKT POI1  DST
  57.       DATA LEFCOQ /   44,  27,  56,  49,  41,  28,  45,  93 /
  58.  
  59.       LOGICAL ltelq, lsupfo
  60. *
  61. * 0) QUELQUES INITIALISATIONS
  62. *
  63.       IPTFP = 0
  64.       NHRM = NIFOUR
  65. C= Composantes du CHPOINT IPCHPS a retenir (si besoin)
  66.       IF (IFOMOD.EQ.2) THEN
  67.         nfors = 3
  68.         mfors(1) = 'FX  '
  69.         mfors(2) = 'FY  '
  70.         mfors(3) = 'FZ  '
  71.       ELSE IF (IFOMOD.EQ.-1) THEN
  72.         nfors = 2
  73.         mfors(1) = 'FX  '
  74.         mfors(2) = 'FY  '
  75.         mfors(3) = '    '
  76.       ELSE IF (IFOMOD.EQ.0) THEN
  77.         nfors = 2
  78.         mfors(1) = 'FR  '
  79.         mfors(2) = 'FZ  '
  80.         mfors(3) = '    '
  81.       ELSE IF (IFOMOD.EQ.1) THEN
  82.         nfors = 3
  83.         mfors(1) = 'FR  '
  84.         mfors(2) = 'FZ  '
  85.         mfors(3) = 'FT  '
  86.       ELSE
  87.         CALL ERREUR(21)
  88.         RETURN
  89.       ENDIF
  90. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  91.       IF (IFOUR.EQ.-3) THEN
  92.         NDPGE = 3
  93.       ELSE
  94.         NDPGE = 0
  95.       ENDIF
  96.  
  97.       IPCHMS = 0
  98.       IPCHMZ = 0
  99.  
  100.       NBTYPE = 1
  101.       SEGINI,NOTYPE
  102.       notype.TYPE(1) = 'REAL*8'
  103.       MOTYR8 = notype
  104. *
  105. * 1) ON RECUPERE LES COORDONNEES DU VECTEUR CONSTANT (SI DONNE)
  106. *
  107.       V(1) = 0.D0
  108.       V(2) = 0.D0
  109.       V(3) = 0.D0
  110.       IF (IPVECT.NE.0) THEN
  111.         IREF=(IPVECT-1)*(IDIM+1)
  112.         V(1)=XCOOR(IREF+1)
  113.         V(2)=XCOOR(IREF+2)
  114.         VN = V(1)**2 + V(2)**2
  115.         IF (IDIM.GE.3) THEN
  116.           V(3)=XCOOR(IREF+3)
  117.           VN=VN+V(3)**2
  118.         ENDIF
  119. c*        VN=SQRT(VN)
  120.         IF (VN.LE.0.) THEN
  121.           CALL ERREUR(277)
  122.           RETURN
  123.         ENDIF
  124.       ENDIF
  125. *
  126. * 2) VERIFICATIONS DU CHAMP DE CARACTERISTIQUES SI FOURNI
  127. *
  128.       IF (IPCARA.NE.0) THEN
  129.         CALL QUESUP(IPMODL,IPCARA,3,0,ISUPCA,iret)
  130.         IF (ISUPCA.GT.1) RETURN
  131.       ENDIF
  132. *
  133. * 3) ANALYSE DU CHPOINT DE FORCES SURFACIQUES SI DONNE
  134. *    IFLAG SERT A INDIQUER SI L'ON DOIT OU NON DETRUIRE LE MODELE IPMODI
  135. *    ( 1 = DESTRUCTION DU MMODEL IPMODI CREE )
  136. *
  137.       IF (IPCHPS.NE.0) THEN
  138. *
  139.         IFLAG = 1
  140. *
  141. *    ON CREE L OBJET MAILLAGE CONTENANT TOUS LES POINTS DU CHPOINT
  142. *    CORRESPONDANT AUX SEULES COMPOSANTES RECHERCHEES (mfors)
  143. *
  144.         IPGEOM = 0
  145. *
  146.         MCHPOI=IPCHPS
  147.         NSOUPO=IPCHP(/1)
  148.         ltelq=.FALSE.
  149.         DO I = 1, NSOUPO
  150.           MSOUPO=IPCHP(I)
  151.           NC = NOCOMP(/2)
  152.           DO j = 1, NC
  153.             CALL PLACE(mfors,nfors,imo,NOCOMP(j))
  154.             IF (imo.NE.0) THEN
  155.               IF (IPGEOM.EQ.0) THEN
  156.                 IPGEOM = IGEOC
  157.               ELSE
  158.                 IPP2 = IGEOC
  159.                 CALL FUSE (IPGEOM,IPP2,IPPT,ltelq)
  160.                 IF (IERR.NE.0) RETURN
  161.                 IPGEOM = IPPT
  162.               ENDIF
  163.               GOTO 10
  164.             ENDIF
  165.           ENDDO
  166.  10       CONTINUE
  167.         ENDDO
  168.  
  169.         IF (IPGEOM.EQ.0) THEN
  170.           CALL ERREUR(21)
  171.           RETURN
  172.         ENDIF
  173. *
  174. *    ON CREE UN MODELE S'ACCROCHANT AU CHPOINT
  175. *
  176.         MMODEL = IPMODL
  177.         NSOUS = MMODEL.KMODEL(/1)
  178. *
  179.         N1 = NSOUS
  180.         SEGINI,MMODE1=MMODEL
  181.         IPMODI = MMODE1
  182. *
  183. *     BOUCLE SUR LES SOUS ZONES GEOMETRIQUES ELEMENTAIRES
  184. *
  185.         N1 = 0
  186.         lzero = 0
  187. *
  188.         DO 11 ISOUS = 1, NSOUS
  189. *
  190.           IMODEL=KMODEL(ISOUS)
  191.           ITGEOM=IMAMOD
  192. *
  193.           CALL ECROBJ('MAILLAGE',IPGEOM)
  194.           CALL ECRCHA('STRI')
  195.           CALL ECRCHA('APPU')
  196.           CALL ECROBJ('MAILLAGE',ITGEOM)
  197.           CALL EXTREL(irr,0,ibnor)
  198. *
  199. *    LE CHPOINT ET LA SOUS-ZONE N'ONT PAS D'ELEMENT EN COMMUN
  200. *
  201.           IF (irr.GT.0) GOTO 11
  202. *
  203. *    DEFINITION DU SOUS-MODELE ASSOCIE A L'INTERSECTION
  204.           CALL LIROBJ('MAILLAGE',IPOGEO,1,IRETOU)
  205.           CALL ACTOBJ('MAILLAGE',IPOGEO,1)
  206.           IF (IERR.NE.0) GOTO 9990
  207. *
  208.           N1 = N1 + 1
  209. *
  210. *    CREATION DE L'OBJET IMODEL DE CETTE SOUS ZONE
  211. *
  212.           SEGINI,IMODE1=IMODEL
  213.           IMODE1.IMAMOD=IPOGEO
  214.           CALL INOMID(IMODE1,lzero,lzero,lzero,lzero)
  215.           CALL PRQUOI(IMODE1)
  216.           MMODE1.KMODEL(N1) = IMODE1
  217. *
  218.  11     CONTINUE
  219. *
  220. *  LE MODELE ET LE CHPOINT SONT INCOMPATIBLES
  221. *
  222.         IF (N1.EQ.0) THEN
  223.           MOTERR(1:8)='MAILLAGE'
  224.           MOTERR(9:16)='CHPOINT'
  225.           CALL ERREUR(135)
  226.           IFLAG = 0
  227.           SEGSUP,MMODE1
  228.           GOTO 9990
  229.         ENDIF
  230. *
  231.         IF (N1.NE.NSOUS) THEN
  232.           SEGADJ,MMODE1
  233.         ENDIF
  234. *
  235. *  ON TRANSFORME LE CHPOINT DE VECTEUR EN MCHAML AUX NOEUDS
  236. *
  237.         CALL CHAME1(0,IPMODI,IPCHPS,' ',IPCHMS,1)
  238.         IF (IERR.NE.0) GOTO 9990
  239.  
  240.         MCHEL1=IPCHMS
  241. *
  242.       ELSE
  243.         IFLAG = 0
  244.         IPMODI = IPMODL
  245.  
  246.       ENDIF
  247. *
  248. *     ACTIVATION DU MODELE
  249. *
  250.       MMODEL = IPMODI
  251.       NSOUS = KMODEL(/1)
  252. *
  253. *     INITIALISATION DU MCHAML ELEMENTAIRE DES FORCES NODALES
  254. *
  255.       N1 = NSOUS
  256.       L1 = 6
  257.       N3 = 6
  258.       SEGINI,MCHELM
  259.       IPCHMZ = MCHELM
  260.       TITCHE = 'FORCES'
  261.       IFOCHE = IFOUR
  262.  
  263.       DO 100 ISOUS = 1, NSOUS
  264. *
  265. *        ON RECUPERE L INFORMATION GENERALE
  266. *
  267.         IMODEL=KMODEL(ISOUS)
  268. *
  269.         MOCARA = 0
  270.         IVACAR = 0
  271.         MOFORC = 0
  272.         IVAFOR = 0
  273. *
  274. *        TRAITEMENT DU MODEL
  275. *
  276.         IPMAIL=IMAMOD
  277.         CONM  =CONMOD
  278.         MELE  =NEFMOD
  279.  
  280.         imo = 0
  281.         CALL PLACE2(LEFCOQ,NEFCOQ,imo,MELE)
  282. *
  283. *     ERREUR L ELEMENT N EST PAS ENCORE IMPLEMENTE
  284.         IF (imo.EQ.0) THEN
  285.           MOTERR(1:4) = NOMTP(MELE)
  286.           MOTERR(5:12)='FSURCO  '
  287.           CALL ERREUR(86)
  288.           ipchmz=0
  289.           ipchms=0
  290.           GOTO 9900
  291.         ENDIF
  292.  
  293.         IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  294.           IF (IPCARA.EQ.0) THEN
  295. C* Revoir l'erreur
  296.             MOTERR(1:4) = NOMTP(MELE)
  297.             MOTERR(5:12)='FSURCO  '
  298.             CALL ERREUR(86)
  299.           ipchmz=0
  300.           ipchms=0
  301.             GOTO 9900
  302.           ENDIF
  303.         ENDIF
  304. *
  305. *        INFORMATION SUR L ELEMENT FINI
  306. *
  307.         MFR   =INFELE(13)
  308.         IPTINT=INFMOD(5)
  309. c*        IPTNOE=INFMOD(8)
  310.         IPTNOE=INFELE(12)
  311.         MINTE =IPTINT
  312.         IPPORE=0
  313.         IF (MFR.EQ.33) IPPORE=NBNN
  314. *
  315. *        CREATION DU TABLEAU INFOS
  316. *
  317.         CALL IDENT(IPMAIL,CONM,IPCARA,IPCHMS,INFOS,iret)
  318.         IF (iret.EQ.0) GOTO 9900
  319. *
  320.         IPT(1) = 0
  321.         IPT(2) = 0
  322.         IPT(3) = 0
  323.         IF (IPCHMS.NE.0) THEN
  324.           MCHAM1 = MCHEL1.ICHAML(ISOUS)
  325.           DO i = 1, MCHAM1.NOMCHE(/2)
  326.             CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i))
  327.             if (imo.ne.0) IPT(imo) = MCHAM1.IELVAL(i)
  328.           ENDDO
  329.         ENDIF
  330. *
  331.         IMACHE(ISOUS)=IPMAIL
  332.         CONCHE(ISOUS)=CONM
  333.         INFCHE(ISOUS,1)=0
  334.         INFCHE(ISOUS,2)=0
  335.         INFCHE(ISOUS,3)=NHRM
  336.         INFCHE(ISOUS,4)=IPTINT
  337.         INFCHE(ISOUS,5)=0
  338.         INFCHE(ISOUS,6)=3
  339. *
  340.         MELEME=IPMAIL
  341.         NBNN  =NUM(/1)
  342.         NBELEM=NUM(/2)
  343. *
  344. *        RECHERCHE DES NOMS DE COMPOSANTES
  345. *
  346.         IF (lnomid(2).ne.0) then
  347.           lsupfo = .false.
  348.           MOFORC = lnomid(2)
  349.         else
  350.           lsupfo = .true.
  351.           CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC)
  352.         endif
  353.         nomid=MOFORC
  354.         nfor = lesobl(/2)
  355.         nfac = 0
  356.         NCOMP = NFOR - NDPGE
  357.  
  358.         N2 = NCOMP
  359.         SEGINI,MCHAML
  360.         ICHAML(ISOUS) = MCHAML
  361.         NSR=1
  362.         NCOSOR=NCOMP
  363.         SEGINI,MPTVAL
  364.         IVAFOR=MPTVAL
  365.  
  366.         N1EL = NBELEM
  367.         IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  368.      &      MELE.EQ.93) THEN
  369.           N1PTEL = 3
  370.         ELSE IF (MELE.EQ.44) THEN
  371.           N1PTEL = 2
  372.         ELSE IF (MELE.EQ.49 .OR. MELE.EQ.41 .OR. MELE.EQ.56) THEN
  373.            N1PTEL=NBNN
  374.         ENDIF
  375.         N2PTEL=0
  376.         N2EL  =0
  377.  
  378.         DO 4 ICOMP = 1, NCOMP
  379.           NOMCHE(ICOMP) = LESOBL(ICOMP)
  380.           TYPCHE(ICOMP)='REAL*8'
  381.           SEGINI,MELVAL
  382.           IELVAL(ICOMP)=MELVAL
  383.           IVAL(ICOMP)=MELVAL
  384.  4      CONTINUE
  385. *_______________________________________________________________________
  386. *
  387. *          CALCUL DES FORCES NODALES EQUIVALENTES
  388. *        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  389. *_______________________________________________________________________
  390. *
  391. *        ELEMENTS COQ3 , DKT OU DKTC
  392. *        ---------------------------
  393.         IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  394.      &      MELE.EQ.93) THEN
  395. *
  396.           CALL FSCO3D(IPT,IPMAIL,IPVECT,V,IVAFOR)
  397. *
  398. *        ELEMENT COQ2
  399. *        ------------
  400.         ELSE IF (MELE.EQ.44) THEN
  401. *
  402. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  403. *
  404.           IF (IFOUR.EQ.-2 .AND. IPCARA.NE.0) THEN
  405. *
  406.             NBROBL=0
  407.             NBRFAC=1
  408.             SEGINI,NOMID
  409.             MOCARA=NOMID
  410.             LESFAC(1)='DIM3'
  411.  
  412.             NCARA=NBROBL
  413.             NCARF=NBRFAC
  414.             NCARR=NCARA+NCARF
  415.  
  416.             CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYR8,0,
  417.      &                                       INFOS,3,IVACAR)
  418.             IF (IERR.NE.0) GOTO 9990
  419.  
  420.             IF (ISUPCA.EQ.1) THEN
  421.               CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  422.             ENDIF
  423. *
  424.           ENDIF
  425.  
  426.           CALL FSCO2D (IPT,IPMAIL,IPVECT,V,IVAFOR,IVACAR)
  427. *
  428. *       ELEMENTS COQ4
  429. *       -------------
  430. *
  431.         ELSE IF (MELE.EQ.49) THEN
  432. *
  433.          CALL FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR)
  434. *
  435. *       ELEMENTS COQ6 OU COQ8
  436. *       ---------------------
  437. *
  438.         ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  439. *____________________________________________________________________
  440. *
  441. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES POUR LES COQ8 ET COQ6
  442. *____________________________________________________________________
  443. *
  444.           NBROBL=1
  445.           NBRFAC=0
  446.           SEGINI,NOMID
  447.           MOCARA=NOMID
  448.           LESOBL(1)='EPAI'
  449.  
  450.           NCARA=NBROBL
  451.           NCARF=NBRFAC
  452.           NCARR=NCARA+NCARF
  453.  
  454.           CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYR8,1,INFOS,3,IVACAR)
  455.           IF (IERR.NE.0) GOTO 9990
  456.  
  457.           IF (ISUPCA.EQ.1) THEN
  458.             CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  459.           ENDIF
  460.  
  461.           CALL FSCOQ8(IPT,IPMAIL,IPTINT,IPVECT,V,IVACAR,IPTNOE,IVAFOR)
  462.  
  463.         ENDIF
  464. *
  465.         IF (MOCARA.NE.0) THEN
  466.           NOMID = MOCARA
  467.           SEGSUP,NOMID
  468.           IF (ISUPCA.EQ.1) THEN
  469.             CALL DTMVAL(IVACAR,3)
  470.           ELSE
  471.             CALL DTMVAL(IVACAR,1)
  472.           ENDIF
  473.         ENDIF
  474. *
  475.         IF (MOFORC.NE.0) THEN
  476.           nomid=MOFORC
  477.           IF (lsupfo) SEGSUP,nomid
  478.           CALL DTMVAL(IVAFOR,1)
  479.         ENDIF
  480. *
  481.  100  CONTINUE
  482.  
  483. *
  484. *     ON TRANSFORME LE MCHAML EN CHPOINT
  485. *
  486.         CALL CHAMPO(IPCHMZ,0,IPTFP,iret)
  487.         IF (iret.EQ.0) GOTO 9990
  488. *
  489. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  490. *
  491.  9900 CONTINUE
  492.  9990 CONTINUE
  493. *
  494.       IF (IFLAG .EQ.1) CALL DTMODL(IPMODI)
  495.       IF (IPCHMZ.NE.0) CALL DTCHAM(IPCHMZ)
  496.  
  497.       notype = MOTYR8
  498.       SEGSUP,notype
  499.  
  500. C      RETURN
  501.       END
  502.  
  503.  
  504.  

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