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    CB215821  24/04/12    21:16:07     11897          
  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.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. -INC CCHAMP
  31. *
  32. -INC SMCOORD
  33. -INC SMELEME
  34. -INC SMMODEL
  35. -INC SMCHAML
  36. -INC SMCHPOI
  37. -INC SMINTE
  38. *
  39.       SEGMENT NOTYPE
  40.         CHARACTER*16 TYPE(NBTYPE)
  41.       ENDSEGMENT
  42. *
  43.       SEGMENT MPTVAL
  44.         INTEGER IPOS(NS)    ,NSOF(NS)
  45.         INTEGER      IVAL(NCOSOU)
  46.         CHARACTER*16 TYVAL(NCOSOU)
  47.       ENDSEGMENT
  48. *
  49.       PARAMETER (NINF=3)
  50.       INTEGER INFOS(NINF)
  51.  
  52.       DIMENSION V(3),ipt(3)
  53.       CHARACTER*(LOCOMP) mfors(3)
  54.       CHARACTER*(NCONCH) CONM
  55.  
  56. C=  LEFCOQ   Liste des numeros d'elements finis COQUEs
  57. C=  NEFCOQ   Longueur de cette liste
  58.       PARAMETER ( NEFCOQ = 8 )
  59.       DIMENSION LEFCOQ(NEFCOQ)
  60. C ============
  61. C  Elements COQUEs  COQ2 COQ3 COQ6 COQ4 COQ8  DKT POI1  DST
  62.       DATA LEFCOQ /   44,  27,  56,  49,  41,  28,  45,  93 /
  63.  
  64.       LOGICAL ltelq, lsupfo
  65. *
  66. * 0) QUELQUES INITIALISATIONS
  67. *
  68.       IPTFP = 0
  69.       NHRM = NIFOUR
  70. C= Composantes du CHPOINT IPCHPS a retenir (si besoin)
  71.       IF (IFOMOD.EQ.2) THEN
  72.         nfors = 3
  73.         mfors(1) = 'FX  '
  74.         mfors(2) = 'FY  '
  75.         mfors(3) = 'FZ  '
  76.       ELSE IF (IFOMOD.EQ.-1) THEN
  77.         nfors = 2
  78.         mfors(1) = 'FX  '
  79.         mfors(2) = 'FY  '
  80.         mfors(3) = '    '
  81.       ELSE IF (IFOMOD.EQ.0) THEN
  82.         nfors = 2
  83.         mfors(1) = 'FR  '
  84.         mfors(2) = 'FZ  '
  85.         mfors(3) = '    '
  86.       ELSE IF (IFOMOD.EQ.1) THEN
  87.         nfors = 3
  88.         mfors(1) = 'FR  '
  89.         mfors(2) = 'FZ  '
  90.         mfors(3) = 'FT  '
  91.       ELSE
  92.         CALL ERREUR(21)
  93.         RETURN
  94.       ENDIF
  95. C= Cas des modes de calculs en DEFORMATIONS GENERALISEES
  96.       IF (IFOUR.EQ.-3) THEN
  97.         NDPGE = 3
  98.       ELSE
  99.         NDPGE = 0
  100.       ENDIF
  101. *
  102.       IPCHMS = 0
  103.       IPCHMZ = 0
  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,'        ',iret,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.         IPTNOE=INFMOD(8)
  310.         MINTE =IPTINT
  311.         IPPORE=0
  312.         IF (MFR.EQ.33) IPPORE=NBNN
  313. *
  314. *        CREATION DU TABLEAU INFOS
  315. *
  316.         CALL IDENT(IPMAIL,CONM,IPCARA,IPCHMS,INFOS,iret)
  317.         IF (iret.EQ.0) GOTO 9900
  318. *
  319.         IPT(1) = 0
  320.         IPT(2) = 0
  321.         IPT(3) = 0
  322.         IF (IPCHMS.NE.0) THEN
  323.           MCHAM1 = MCHEL1.ICHAML(ISOUS)
  324.           DO i = 1, MCHAM1.NOMCHE(/2)
  325.             CALL PLACE(mfors,nfors,imo,MCHAM1.NOMCHE(i))
  326.             if (imo.ne.0) IPT(imo) = MCHAM1.IELVAL(i)
  327.           ENDDO
  328.         ENDIF
  329. *
  330.         IMACHE(ISOUS)=IPMAIL
  331.         CONCHE(ISOUS)=CONM
  332.         INFCHE(ISOUS,1)=0
  333.         INFCHE(ISOUS,2)=0
  334.         INFCHE(ISOUS,3)=NHRM
  335.         INFCHE(ISOUS,4)=IPTINT
  336.         INFCHE(ISOUS,5)=0
  337.         INFCHE(1,6)=0
  338. *
  339.         MELEME=IPMAIL
  340.         NBNN  =NUM(/1)
  341.         NBELEM=NUM(/2)
  342. *
  343. *        RECHERCHE DES NOMS DE COMPOSANTES
  344. *
  345.         IF (lnomid(2).ne.0) then
  346.           lsupfo = .false.
  347.           MOFORC = lnomid(2)
  348.         else
  349.           lsupfo = .true.
  350.           CALL IDFORC (MFR,IFOUR,MOFORC,NFOR,NFAC)
  351.         endif
  352.         nomid=MOFORC
  353.         nfor = lesobl(/2)
  354.         nfac = 0
  355.         NCOMP = NFOR - NDPGE
  356.  
  357.         N2 = NCOMP
  358.         SEGINI,MCHAML
  359.         ICHAML(ISOUS) = MCHAML
  360.         NS=1
  361.         NCOSOU=NCOMP
  362.         SEGINI,MPTVAL
  363.         IVAFOR=MPTVAL
  364. *
  365.         N1EL = NBELEM
  366.         IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  367.      &      MELE.EQ.93) THEN
  368.           N1PTEL = 3
  369.         ELSE IF (MELE.EQ.44) THEN
  370.           N1PTEL = 2
  371.         ELSE IF (MELE.EQ.49 .OR. MELE.EQ.41 .OR. MELE.EQ.56) THEN
  372.            N1PTEL=NBNN
  373.         ENDIF
  374.         N2PTEL=0
  375.         N2EL  =0
  376. *
  377.         DO 4 ICOMP = 1, NCOMP
  378.           NOMCHE(ICOMP) = LESOBL(ICOMP)
  379.           TYPCHE(ICOMP)='REAL*8'
  380.           SEGINI,MELVAL
  381.           IELVAL(ICOMP)=MELVAL
  382.           IVAL(ICOMP)=MELVAL
  383.  4      CONTINUE
  384. *_______________________________________________________________________
  385. *
  386. *          CALCUL DES FORCES NODALES EQUIVALENTES
  387. *        DEBRANCHEMENT SUIVANT LE TYPE DES ELEMENTS
  388. *_______________________________________________________________________
  389. *
  390. *        ELEMENTS COQ3 , DKT OU DKTC
  391. *        ---------------------------
  392.         IF (MELE.EQ.27 .OR. MELE.EQ.28 .OR. MELE.EQ.45 .OR.
  393.      &      MELE.EQ.93) THEN
  394. *
  395.           CALL FSCO3D(IPT,IPMAIL,IPVECT,V,IVAFOR)
  396. *
  397. *        ELEMENT COQ2
  398. *        ------------
  399.         ELSE IF (MELE.EQ.44) THEN
  400. *
  401. * TRAITEMENT DU CHAMP DE CARACTERISTIQUES
  402. *
  403.           IF (IFOUR.EQ.-2 .AND. IPCARA.NE.0) THEN
  404. *
  405.             NBROBL=0
  406.             NBRFAC=1
  407.             SEGINI,NOMID
  408.             MOCARA=NOMID
  409.             LESFAC(1)='DIM3'
  410. *
  411.             NBTYPE=1
  412.             SEGINI,NOTYPE
  413.             MOTYPE=NOTYPE
  414.             TYPE(1)='REAL*8'
  415. *
  416.             CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,0,
  417.      &                                       INFOS,3,IVACAR)
  418.             SEGSUP,NOTYPE
  419.             IF (IERR.NE.0) GOTO 9990
  420. *
  421.             IF (ISUPCA.EQ.1) THEN
  422.               NCARA=NBROBL
  423.               NCARF=NBRFAC
  424.               NCARR=NCARA+NCARF
  425.               CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  426.             ENDIF
  427. *
  428.           ENDIF
  429.  
  430.           CALL FSCO2D (IPT,IPMAIL,IPVECT,V,IVAFOR,IVACAR)
  431. *
  432. *       ELEMENTS COQ4
  433. *       -------------
  434. *
  435.         ELSE IF (MELE.EQ.49) THEN
  436. *
  437.          CALL FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR)
  438. *
  439. *       ELEMENTS COQ6 OU COQ8
  440. *       ---------------------
  441. *
  442.         ELSE IF (MELE.EQ.41.OR.MELE.EQ.56) THEN
  443. *____________________________________________________________________
  444. *
  445. * TRAITEMENT DES CHAMPS DE CARACTERISTIQUES POUR LES COQ8 ET COQ6
  446. *____________________________________________________________________
  447. *
  448.           NBROBL=1
  449.           NBRFAC=0
  450.           SEGINI,NOMID
  451.           MOCARA=NOMID
  452.           LESOBL(1)='EPAI'
  453. *
  454.           NBTYPE=1
  455.           SEGINI,NOTYPE
  456.           MOTYPE=NOTYPE
  457.           TYPE(1)='REAL*8'
  458. *
  459. *
  460.           CALL KOMCHA(IPCARA,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR)
  461.           SEGSUP,NOTYPE
  462.           IF (IERR.NE.0) GOTO 9990
  463. *
  464.           IF (ISUPCA.EQ.1) THEN
  465.             NCARA=NBROBL
  466.             NCARF=NBRFAC
  467.             NCARR=NCARA+NCARF
  468.             CALL VALCHE(IVACAR,NCARR,IPTINT,IPPORE,MOCARA,MELE)
  469.           ENDIF
  470. *
  471.           CALL FSCOQ8(IPT,IPMAIL,IPTINT,IPVECT,V,IVACAR,IPTNOE,IVAFOR)
  472. *
  473.         ENDIF
  474. *
  475. *
  476.         IF (MOCARA.NE.0) THEN
  477.           NOMID = MOCARA
  478.           SEGSUP,NOMID
  479.           IF (ISUPCA.EQ.1) THEN
  480.             CALL DTMVAL(IVACAR,3)
  481.           ELSE
  482.             CALL DTMVAL(IVACAR,1)
  483.           ENDIF
  484.         ENDIF
  485. *
  486.         IF (MOFORC.NE.0) THEN
  487.           nomid=MOFORC
  488.           IF (lsupfo) SEGSUP,nomid
  489.           CALL DTMVAL(IVAFOR,1)
  490.         ENDIF
  491. *
  492.  100  CONTINUE
  493.  
  494. *
  495. *     ON TRANSFORME LE MCHAML EN CHPOINT
  496. *
  497.         CALL CHAMPO(IPCHMZ,0,IPTFP,iret)
  498.         IF (iret.EQ.0) GOTO 9990
  499. *
  500. *     ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR
  501. *
  502.  9900 CONTINUE
  503.  9990 CONTINUE
  504. *
  505.       IF (IFLAG .EQ.1) CALL DTMODL(IPMODI)
  506.       IF (IPCHMZ.NE.0) CALL DTCHAM(IPCHMZ)
  507.  
  508.       END
  509.  
  510.  
  511.  
  512.  
  513.  
  514.  
  515.  
  516.  

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