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

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