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

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