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

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