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

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