Télécharger la plaquette Cast3M


fr en

Télécharger pola1.eso

Retour à la liste

Numérotation des lignes : 

pola1

  1. C POLA1     SOURCE    CB215821  24/04/12    21:16:52     11897          
  2.       SUBROUTINE POLA1(IPMODL,IPCHE1,IPCHE2,IPCHE3,IMIL)
  3. *---------------------------------------------------------------------
  4. *
  5. *      CALCUL DE LA DECOMPOSITION POLAIRE
  6. *                 (APPELE PAR POLA)
  7. *
  8. *   ENTREES:
  9. *   --------
  10. *
  11. *     IPMODL   POINTEUR SUR UN MMODEL
  12. *     IPCHE1   POINTEUR SUR UN CHAMELEM DE GRADIENTS
  13. *              (TYPE MCHAML)
  14. *     IMIL     INDICATEUR DEPL OU GEOM SELON QUE LE
  15. *              GRADIENT EST CELUI D'UN DEPLACEMENT
  16. *              OU D'UNE GEOMETRIE
  17. *
  18. *  SORTIES :
  19. *  ---------
  20. *
  21. *     IPCHE2   POINTEUR SUR UN CHAMELEM R
  22. *     IPCHE3   POINTEUR SUR UN CHAMELEM U
  23. *
  24. *---------------------------------------------------------------------
  25. *
  26.       IMPLICIT INTEGER(I-N)
  27.       IMPLICIT REAL*8(A-H,O-Z)
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC CCHAMP
  32. -INC SMCHAML
  33. -INC SMMODEL
  34. *
  35.       SEGMENT NOTYPE
  36.         CHARACTER*16 TYPE(NBTYPE)
  37.       ENDSEGMENT
  38. *
  39.       SEGMENT MPTVAL
  40.         INTEGER IPOS(NS)    ,NSOF(NS)
  41.         INTEGER      IVAL(NCOSOU)
  42.         CHARACTER*16 TYVAL(NCOSOU)
  43.       ENDSEGMENT
  44. *
  45.       PARAMETER ( NINF=3 )
  46.       INTEGER INFOS(NINF)
  47.       CHARACTER*(NCONCH) CONM
  48.       LOGICAL lsupgd
  49. *
  50.       DIMENSION F(9),R(9),U(9)
  51.  
  52.       NHRM=NIFOUR
  53. *
  54.       MCHELM=IPCHE1
  55.       SEGACT MCHELM
  56.       IF(TITCHE.NE.'GRADIENT') THEN
  57.          MOTERR(1:8)='GRADIENT'
  58.          CALL ERREUR(145)
  59.          GOTO 666
  60.       ENDIF
  61. *
  62. * ... VERIFICATION DU LIEU SUPPORT DU MCHAML DE GRADIENT
  63. *
  64.       N1=INFCHE(/1)
  65.       N3=INFCHE(/2)
  66.       IF(N3.LT.6) THEN
  67.          ISUP1=1
  68.       ELSE
  69.          ISUP1=INFCHE(1,6)
  70.          DO 1000 ISCHAM=2,N1
  71.             IF(INFCHE(ISCHAM,6).NE.ISUP1) THEN
  72.                CALL ERREUR(560)
  73.                SEGDES,MCHELM
  74.                RETURN
  75.             ENDIF
  76.  1000    CONTINUE
  77.       ENDIF
  78. *
  79. * ... ACTIVATION DU MODELE ...
  80. *
  81.       MMODEL=IPMODL
  82.       SEGACT MMODEL
  83.       NSOUS=KMODEL(/1)
  84.  
  85. C ... Initialisation des deux nouveaux MCHELM - résultats ...
  86. C     les MCHAML resultats sont types GRADIENT pour simplifier
  87. C       la gestion des noms des composantes
  88. C
  89.  
  90.       N1=NSOUS
  91.       L1=8
  92.       N3=6
  93. *
  94.       SEGINI MCHEL1
  95.       IPCHE2=MCHEL1
  96.       MCHEL1.IFOCHE=IFOUR
  97.       MCHEL1.TITCHE='GRADIENT'
  98. *
  99.       SEGINI MCHEL2
  100.       IPCHE3=MCHEL2
  101.       MCHEL2.IFOCHE=IFOUR
  102.       MCHEL2.TITCHE='GRADIENT'
  103. *
  104. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  105. *
  106.       DO 200 ISOUS=1,NSOUS
  107. *
  108. *    ... INITIALISATION ...
  109. *
  110.          NCOMP=0
  111.          IVACOM = 0
  112.          MOCOMP = 0
  113.          IVAGR1 = 0
  114.          IVAGR2 = 0
  115.          IMODEL=KMODEL(ISOUS)
  116.          SEGACT IMODEL
  117. *
  118.          IPMAIL=IMAMOD
  119.          CONM  =CONMOD
  120.          MELE  =NEFMOD
  121. C
  122. C    ... COQUE INTEGREE OU PAS ? ...
  123. C
  124.          IF(INFMOD(/1).NE.0)THEN
  125.             NPINT=INFMOD(1)
  126.          ELSE
  127.             NPINT=0
  128.          ENDIF
  129.          IF (NPINT.NE.0)THEN
  130.             CALL ERREUR(615)
  131.             SEGDES IMODEL,MMODEL
  132.             SEGSUP MCHEL1,MCHEL2
  133.             GOTO 666
  134.          ENDIF
  135. *
  136. *    ... INFORMATION SUR L'ELEMENT FINI ...
  137. *
  138. *         CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL)
  139.          IF (IERR.NE.0) THEN
  140.             SEGDES IMODEL,MMODEL
  141.             SEGSUP MCHEL1,MCHEL2
  142.             GOTO 666
  143.          ENDIF
  144. *
  145. *         INFO  =IPINF
  146.          MFR   =INFELE(13)
  147. *         MINTE =INFELE(11)
  148.          minte=infmod(2+isup1)
  149. *
  150. *    ... Verfication de compatibilité des MCHAML du point de vue des
  151. *        tableaux INFCHE et remplissage du tableau INFOS pour COMCHA ...
  152. *
  153.          CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD)
  154.          IF (IRTD.EQ.0) THEN
  155.             SEGDES IMODEL,MMODEL
  156.             SEGSUP MCHEL1,MCHEL2
  157. *            SEGSUP INFO
  158.             GOTO 666
  159.          ENDIF
  160. *
  161. *    ... Les attributs de chaque sous-zone ...
  162. *
  163.          MCHEL1.INFCHE(ISOUS,1)=0
  164.          MCHEL1.INFCHE(ISOUS,2)=0
  165.          MCHEL1.INFCHE(ISOUS,3)=NHRM
  166.          MCHEL1.INFCHE(ISOUS,4)=MINTE
  167.          MCHEL1.INFCHE(ISOUS,5)=0
  168.          MCHEL1.INFCHE(ISOUS,6)=ISUP1
  169.          MCHEL1.IMACHE(ISOUS)=IPMAIL
  170.          MCHEL1.CONCHE(ISOUS)=CONMOD
  171. *
  172.          MCHEL2.INFCHE(ISOUS,1)=0
  173.          MCHEL2.INFCHE(ISOUS,2)=0
  174.          MCHEL2.INFCHE(ISOUS,3)=NHRM
  175.          MCHEL2.INFCHE(ISOUS,4)=MINTE
  176.          MCHEL2.INFCHE(ISOUS,5)=0
  177.          MCHEL2.INFCHE(ISOUS,6)=ISUP1
  178.          MCHEL2.IMACHE(ISOUS)=IPMAIL
  179.          MCHEL2.CONCHE(ISOUS)=CONMOD
  180. *
  181. *    ... RECHERCHE DES NOMS de COMPOSANTES ...
  182. *
  183.          if(lnomid(3).ne.0) then
  184.           nomid=lnomid(3)
  185.           segact nomid
  186.           mocomp=nomid
  187.           ncomp=lesobl(/2)
  188.           nfac=lesfac(/2)
  189.           lsupgd=.false.
  190.          else
  191.           lsupgd=.true.
  192.           CALL IDGRAD(MFR,IFOUR,MOCOMP,NCOMP,NFAC)
  193.          endif
  194. *
  195. *    ... VERIFICATION DE LEUR PRESENCE ...
  196. *
  197.          NBTYPE=1
  198.          SEGINI NOTYPE
  199.          MOTYPE=NOTYPE
  200.          TYPE(1)='REAL*8'
  201.          CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM)
  202.          SEGSUP NOTYPE
  203.          IF (IERR.NE.0) THEN
  204.             IVASC1=0
  205.             IVASC2=0
  206.             GOTO 9990
  207.          ENDIF
  208. *
  209. *    ... RECHERCHE DA LA TAILLE DES MELVAL A ALLOUER ...
  210. *
  211.          N1PTEL=0
  212.          N1EL=0
  213.          MPTVAL=IVACOM
  214.          DO 110 ICOMP=1,NCOMP
  215.             MELVAL=IVAL(ICOMP)
  216.             N1PTEL=MAX(N1PTEL,VELCHE(/1))
  217.             N1EL  =MAX(N1EL  ,VELCHE(/2))
  218.  110     CONTINUE
  219.          N2PTEL=0
  220.          N2EL=0
  221. *
  222. *    ... Création et stockage des MCHAML ...
  223. *
  224.          N2=NCOMP
  225.          SEGINI MCHAM1
  226.          MCHEL1.ICHAML(ISOUS)=MCHAM1
  227.          SEGINI MCHAM2
  228.          MCHEL2.ICHAML(ISOUS)=MCHAM2
  229. *
  230. C    ... et des MELVAL de la zone élémentaire ...
  231. C
  232.          NS=1
  233.          NCOSOU=NCOMP
  234.          SEGINI MPTVAL
  235.          IVAGR1=MPTVAL
  236.          NOMID=MOCOMP
  237.          SEGACT NOMID
  238.          DO 71 ICOMP=1,NCOMP
  239.              MCHAM1.TYPCHE(ICOMP)='REAL*8'
  240.              MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  241.              SEGINI MELVAL
  242.              MCHAM1.IELVAL(ICOMP)=MELVAL
  243.              IVAL(ICOMP)=MELVAL
  244.   71     CONTINUE
  245. *
  246.          SEGINI MPTVAL
  247.          IVAGR2=MPTVAL
  248.          NOMID=MOCOMP
  249.          SEGACT NOMID
  250.          DO 72 ICOMP=1,NCOMP
  251.              MCHAM2.TYPCHE(ICOMP)='REAL*8'
  252.              MCHAM2.NOMCHE(ICOMP)=LESOBL(ICOMP)
  253.              SEGINI MELVAL
  254.              MCHAM2.IELVAL(ICOMP)=MELVAL
  255.              IVAL(ICOMP)=MELVAL
  256.   72     CONTINUE
  257. *
  258. *
  259. **********************************************************************
  260. *                                                                    *
  261. *               BRANCHEMENT SUIVANT LA DIMENSION                     *
  262. *                                                                    *
  263. **********************************************************************
  264. *
  265.       LADIM=0
  266.       IF(NCOMP.EQ.4) LADIM=2
  267.       IF(NCOMP.EQ.9) LADIM=3
  268.       IF(LADIM.EQ.0) GO TO 9990
  269. *
  270. *   BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS
  271. *
  272.  
  273.       DO 31 IB=1,N1EL
  274.          DO 31 IGAU=1,N1PTEL
  275. *
  276. *       ... Recherche des composantes du gradient
  277. *
  278.             MPTVAL=IVACOM
  279.             DO 35 ICOMP=1,NCOMP
  280.                MELVAL=IVAL(ICOMP)
  281.                IGMN=MIN(IGAU,VELCHE(/1))
  282.                IBMN=MIN(IB  ,VELCHE(/2))
  283.                F(ICOMP)=VELCHE(IGMN,IBMN)
  284.    35       CONTINUE
  285. *
  286. *   on ajoute 1. si on a lu le mot DEPL
  287. *
  288.            IF(IMIL.EQ.1) THEN
  289.              IF(LADIM.EQ.2) THEN
  290.                F(1)=F(1)+1.D0
  291.                F(4)=F(4)+1.D0
  292.              ELSE IF(LADIM.EQ.3) THEN
  293.                F(1)=F(1)+1.D0
  294.                F(5)=F(5)+1.D0
  295.                F(9)=F(9)+1.D0
  296.              ENDIF
  297.            ENDIF
  298. *
  299. *       ... Calcul de R et U
  300. *
  301.          CALL POLA2(F,R,U,LADIM)
  302.          IF(IERR.NE.0) GO TO 9990
  303. *
  304. *       ... et leur stockage ...
  305. *
  306.             MPTVAL=IVAGR1
  307.             DO 36 ICOMP=1,NCOMP
  308.                MELVAL=IVAL(ICOMP)
  309.                VELCHE(IGAU,IB)=R(ICOMP)
  310.    36       CONTINUE
  311.  
  312.             MPTVAL=IVAGR2
  313.             DO 37 ICOMP=1,NCOMP
  314.                MELVAL=IVAL(ICOMP)
  315.                VELCHE(IGAU,IB)=U(ICOMP)
  316.    37       CONTINUE
  317. *
  318.    31 CONTINUE
  319. *
  320. *
  321. *    ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  322. *
  323.             MPTVAL=IVAGR1
  324.             DO 76 ICOMP=1,NCOMP
  325.                MELVAL=IVAL(ICOMP)
  326.                SEGDES MELVAL
  327.    76       CONTINUE
  328.  
  329.             MPTVAL=IVAGR2
  330.             DO 77 ICOMP=1,NCOMP
  331.                MELVAL=IVAL(ICOMP)
  332.                SEGDES MELVAL
  333.    77       CONTINUE
  334. *
  335. *
  336.          SEGDES MCHAM1,MCHAM2
  337. *
  338.          CALL DTMVAL(IVACOM,1)
  339. *
  340.          NOMID=MOCOMP
  341.          if(lsupgd)SEGSUP NOMID
  342. *         SEGSUP INFO
  343. *
  344.          SEGDES IMODEL
  345. *
  346.   200 CONTINUE
  347.  
  348. C ... FIN DE LA GRANDE BOUCLE SUR LES ZONES ÉLÉMENTAIRES ...
  349.  
  350.  
  351.       SEGDES MCHEL1,MCHEL2
  352.       SEGDES MCHELM,MMODEL
  353.       RETURN
  354. *
  355.  9990 CONTINUE
  356. *
  357. * ... ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR ...
  358. *
  359.       SEGDES IMODEL,MMODEL
  360.       SEGSUP MCHEL1,MCHEL2
  361. *
  362.  
  363.       CALL DTMVAL(IVACOM,1)
  364. *
  365.       IF (IVAGR1.NE.0) THEN
  366.             MPTVAL=IVAGR1
  367.             DO 86 ICOMP=1,NCOMP
  368.                MELVAL=IVAL(ICOMP)
  369.                SEGSUP MELVAL
  370.    86       CONTINUE
  371.       ENDIF
  372. *
  373.       IF (IVAGR2.NE.0) THEN
  374.             MPTVAL=IVAGR2
  375.             DO 87 ICOMP=1,NCOMP
  376.                MELVAL=IVAL(ICOMP)
  377.                SEGSUP MELVAL
  378.    87       CONTINUE
  379.       ENDIF
  380. *
  381.       NOMID =MOCOMP
  382.       if(lsupgd)SEGSUP NOMID
  383. *
  384. *      SEGSUP INFO
  385.       RETURN
  386. *
  387.   666 CONTINUE
  388.       SEGDES MCHELM
  389.       RETURN
  390.       END
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.  
  406.  
  407.  

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