Télécharger la plaquette Cast3M


fr en

Télécharger kres24.eso

Retour à la liste

Numérotation des lignes : 

kres24

  1. C KRES24    SOURCE    GOUNAND   25/04/30    21:15:13     12258          
  2.       SUBROUTINE KRES24(KMINCT,KMORS,NNUTOT,MLAG1,MLAG2,
  3.      $        IPERM)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       IMPLICIT INTEGER (I-N)
  6. C***********************************************************************
  7. C     NOM         : KRES24
  8. C     DESCRIPTION : - Placer correctement les multiplicateurs de
  9. C                     Lagrange dans le MATRIK
  10. C
  11. C                     Ce source est une adaptation de KRES14
  12. C
  13. C     LANGAGE     : ESOPE
  14. C     AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  15. C     mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C     VERSION    : v1, 22/04/2025, version initiale
  18. C     HISTORIQUE : v1, 22/04/2025, création
  19. C     HISTORIQUE :
  20. C     HISTORIQUE :
  21. C***********************************************************************
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC CCREEL
  27.       POINTEUR KMINCT.MINC
  28.       POINTEUR KMORS.PMORS
  29.  
  30. -INC SMLENTI
  31.       POINTEUR KTYP.MLENTI
  32.       POINTEUR KRINC.MLENTI
  33.       POINTEUR IWORK.MLENTI
  34.       POINTEUR LAGRAN.MLENTI
  35.       POINTEUR JORDRE.MLENTI,JORTMP.MLENTI
  36.       POINTEUR IPERM.MLENTI,JPETMP.MLENTI
  37.       POINTEUR JPERM.MLENTI,NNUTOT.MLENTI
  38. -INC SMLMOTS
  39.       POINTEUR IORINC.MLMOTS
  40.       POINTEUR IORINU.MLMOTS
  41.       POINTEUR MLAG1.MLMOTS,MLAG2.MLMOTS
  42. -INC SMTABLE
  43.       POINTEUR KTIME.MTABLE
  44.       DIMENSION ITTIME(4)
  45.       CHARACTER*(LOCHPO) CHCOMP
  46.       CHARACTER*16 CHARI
  47.       CHARACTER*1 CCOMP
  48.       LOGICAL LTIME,LDBNUM,LVERIF
  49.       REAL*8 GNRM2
  50. C
  51. C     Executable statements
  52. C
  53.       LDBNUM=.FALSE.
  54.       LVERIF=.FALSE.
  55. *     Pour un non multigrille, il faut quand même placer les
  56. *     multiplicateurs correctement avant et après les inconnues
  57. *     KTYP=-1 multiplicateurs avant
  58. *     KTYP=0  inconnues normales
  59. *     KTYP=+1 multiplicateurs apres
  60. *     IL faut distinguer les 'LX' qui ont deja ete renumerotes et les
  61. *     LXP, MXP
  62.       SEGACT KMINCT
  63.       NCOMP=KMINCT.LISINC(/2)
  64.       NNOE=KMINCT.MPOS(/1)
  65.       INC=KMINCT.NPOS(NNOE+1)-1
  66.       JG=INC
  67.       SEGINI KTYP
  68. *      SEGPRT,KMINCT
  69.       NBLAG=0
  70.       NBNLA=0
  71.       if (mlag1.ne.0) segact mlag1
  72.       if (mlag2.ne.0) segact mlag2
  73. *
  74.       DO ICOMP=1,NCOMP
  75.          CHCOMP=KMINCT.LISINC(ICOMP)
  76.          JTYP=0
  77.          IF (CHCOMP(1:8).EQ.'LX      ') THEN
  78. * Avec les MATRIK, on ne gère que les simples multiplicateurs
  79.             JTYP=2
  80.          ELSE
  81.             if (mlag1.ne.0) then
  82.                CALL PLACE(mlag1.mots,mlag1.mots(/2),imot,chcomp)
  83.                if (imot.ne.0) then
  84.                   JTYP=1
  85.                   GOTO 33
  86.                endif
  87.             else
  88.                IF (CHCOMP(1:2).EQ.'LX') THEN
  89.                   JTYP=1
  90.                   GOTO 33
  91.                endif
  92.             endif
  93.             if (mlag2.ne.0) then
  94.                CALL PLACE(mlag2.mots,mlag2.mots(/2),imot,chcomp)
  95.                if (imot.ne.0) then
  96.                   JTYP=-1
  97.                   GOTO 33
  98.                endif
  99.             else
  100.                IF (CHCOMP(1:2).EQ.'MX') THEN
  101.                   JTYP=-1
  102.                   GOTO 33
  103.                endif
  104.             endif
  105.          ENDIF
  106.  33      CONTINUE
  107.          DO INOE=1,NNOE
  108.             IPOS=KMINCT.MPOS(INOE,ICOMP)
  109.             IF (IPOS.NE.0) THEN
  110.                JPOS=KMINCT.NPOS(INOE)+IPOS-1
  111.                KTYP.LECT(JPOS)=JTYP
  112.                IF (JTYP.NE.0) THEN
  113.                   NBLAG=NBLAG+1
  114.                ELSE
  115.                   NBNLA=NBNLA+1
  116.                ENDIF
  117.             ENDIF
  118.          ENDDO
  119.       ENDDO
  120. *
  121.       if (ldbnum) write(ioimp,*) 'avant tri ktyp=-3'
  122.       if (ldbnum) segprt,ktyp
  123. *
  124.       IF (NBLAG.EQ.0) THEN
  125.          IPERM=NNUTOT
  126.          RETURN
  127.       ENDIF
  128.       NBDDL=NBLAG+NBNLA
  129.       JG=NBLAG
  130.       SEGINI LAGRAN
  131.       ILAG=0
  132.       DO IDDL=1,NBDDL
  133.          ITYP=KTYP.LECT(IDDL)
  134.          IF (ITYP.NE.0) THEN
  135.             ILAG=ILAG+1
  136.             LAGRAN.LECT(ILAG)=IDDL
  137.          ENDIF
  138.       ENDDO
  139.       if (ldbnum) write(ioimp,*) 'apres tri ktyp=-3'
  140.       if (ldbnum) SEGPRT,KTYP
  141.       IF (NBLAG.NE.ILAG) GOTO 9999
  142. *
  143. *     Placement des multiplicateurs inspiré de NUMOP2
  144. *
  145.       segact nnutot
  146.       JG=NBDDL
  147.       SEGINI,JPERM
  148.       DO I=1,NBDDL
  149.          JPERM.LECT(NNUTOT.LECT(I))=I
  150.       ENDDO
  151. *      SEGINI,JPERM=NNUTOT
  152. *     Il y a cinq types différents de -2 à 2 : il faut pouvoir placer
  153. *     les multiplicateurs de lagrange entre les autres noeuds
  154.       NTYP=5
  155.       JG=NBDDL
  156.       SEGINI JORDRE
  157.       DO I=1,NBDDL
  158.          JORDRE.LECT(I)=I*NTYP
  159.       ENDDO
  160.       JORMAX= (NBDDL+1)*NTYP
  161.  
  162.       if (ldbnum) write(ioimp,*) 'Avant mise a la bonne place'
  163.       if (ldbnum) segprt,jordre
  164. *     mise a la bonne place des multiplicateurs de Lagrange
  165.       SEGACT KMORS
  166.       NTT=KMORS.IA(/1)-1
  167.       IF (NTT.NE.NBDDL) THEN
  168.          write(ioimp,*) 'Pas egaux NTT,NBDDL=',NTT,NBDDL
  169.          GOTO 9999
  170.       ENDIF
  171.       do 700 J=1,NBLAG
  172.          IDDL=LAGRAN.LECT(J)
  173.          ITYP=KTYP.LECT(IDDL)
  174.          ICOLD=KMORS.IA(IDDL)
  175.          ICOLF=KMORS.IA(IDDL+1)-1
  176.          iddln=nnutot.lect(iddl)
  177. *         if (ldbnum)write(ioimp,*) 'iddl,ityp,iddln=',iddl,ityp,iddln
  178. *     write (6,*) 'kres24 ',(kmors.JA(icol),icol=icold,icolf)
  179.          ipaur=-igrand
  180.          ipaus=igrand
  181.          do 800 ICOL=ICOLD,ICOLF
  182.             JDDL=KMORS.JA(ICOL)
  183.             JTYP=KTYP.LECT(JDDL)
  184.             IF (ABS(ITYP).NE.ABS(JTYP)) THEN
  185.                JDDLN=NNUTOT.LECT(JDDL)
  186. *               write(ioimp,*) '  jddl,jtyp,jddln=',jddl,jtyp,jddln
  187. *     deplacer les noeuds en relation en fin de zone
  188.                jordre.lect(jddln)=-abs(jordre.lect(jddln))
  189.                ipaur=max(ipaur,jordre.lect(jddln))
  190.                ipaus=min(ipaus,jordre.lect(jddln))
  191.             else
  192. *               write(ioimp,*) '  jddl,jtyp=',jddl,jtyp
  193.             endif
  194.  800     continue
  195. *
  196. *     On va laisser comme ça
  197. *     Ce cas peut arriver après élimination
  198. *     Cela devrait revenir à placer les multiplicateurs en fin ou début
  199. *     de matrice
  200.          if (ipaur.eq.-igrand.or.ipaus.eq.igrand) then
  201. *            Write(ioimp,*) 'mulag sans relations pas ok'
  202. *            goto 9999
  203.             ipaur=0
  204.             ipaus=-jormax
  205.          endif
  206.          if (ldbnum) write(ioimp,*) 'iddl,ipaur,ipaus=',iddl,ipaur
  207.      $        ,ipaus
  208. *
  209. *     le premier mult avant le premier noeud
  210.          IF (ITYP.EQ.-2) THEN
  211.             JORDRE.LECT(IDDLN)=ipaur+2
  212.          ELSEIF (ITYP.EQ.-1) THEN
  213.             JORDRE.LECT(IDDLN)=ipaur+1
  214. *
  215. *     le deuxieme mult apres le dernier noeud
  216.          ELSEIF (ITYP.EQ.1) THEN
  217.             JORDRE.LECT(IDDLN)= ipaus-1
  218.          ELSEIF (ITYP.EQ.2) THEN
  219.             JORDRE.LECT(IDDLN)= ipaus-2
  220.          ELSEIF (ITYP.NE.0) THEN
  221.             write(ioimp,*) 'ityp=',ityp,' non prevu'
  222.             goto 9999
  223.          ENDIF
  224. *
  225.  700  continue
  226. *     WRITE(IOIMP,*) 'Avant chgt signe'
  227. *     segprt,jordre
  228.       DO I=1,NBDDL
  229.          JORDRE.LECT(I)=-JORDRE.LECT(I)
  230.       ENDDO
  231. *     Avant tri
  232.       if (ldbnum) WRITE(IOIMP,*) 'Avant TRIFUS'
  233.       if (ldbnum) SEGPRT,JPERM
  234.       if (ldbnum) SEGPRT,JORDRE
  235.       JG=NBDDL
  236.       SEGINI JORTMP
  237.       SEGINI JPETMP
  238. *     ok maintenant on trie
  239.       CALL TRIFUS(NBDDL,JORDRE.LECT,JPERM.LECT,JORTMP.LECT
  240.      $     ,JPETMP.LECT)
  241.       SEGSUP JPETMP
  242.       SEGSUP JORTMP
  243. *     Apres tri
  244.       if (ldbnum) WRITE(IOIMP,*) 'Apres TRIFUS'
  245.       if (ldbnum) SEGPRT,JPERM
  246.       if (ldbnum) SEGPRT,JORDRE
  247. *     permutation inverse
  248.       JG=NBDDL
  249.       SEGINI IPERM
  250.       DO I=1,NBDDL
  251.          IPERM.LECT(JPERM.LECT(I))=I
  252.       ENDDO
  253. *     Verification que dans la nouvelle numerotation les multiplicateurs
  254. *     sont correctement places...
  255.       IF (LVERIF) THEN
  256.          write(ioimp,*) 'VERIF KRES24'
  257.          do 1700 J=1,NBLAG
  258.             IDDL=LAGRAN.LECT(J)
  259.             ITYP=KTYP.LECT(IDDL)
  260.             ICOLD=KMORS.IA(IDDL)
  261.             ICOLF=KMORS.IA(IDDL+1)-1
  262.             iddln=iperm.lect(iddl)
  263.             ipaur=-igrand
  264.             ipaus=igrand
  265.             do 1800 ICOL=ICOLD,ICOLF
  266.                JDDL=KMORS.JA(ICOL)
  267.                JTYP=KTYP.LECT(JDDL)
  268.                IF (ABS(ITYP).NE.ABS(JTYP)) THEN
  269.                   JDDLN=IPERM.LECT(JDDL)
  270.                   ipaur=max(ipaur,jddln)
  271.                   ipaus=min(ipaus,jddln)
  272.                endif
  273.  1800       continue
  274.             if (ldbnum) write(ioimp,*) 'iddl,ipaur,ipaus=',iddl,ipaur
  275.      $           ,ipaus
  276.             if (ipaur.eq.-igrand.or.ipaus.eq.igrand) then
  277.                goto 1700
  278. *     Write(ioimp,*) 'mulag sans relations pas ok'
  279. *     goto 9999
  280.             endif
  281.             if (ityp.lt.0) THEN
  282.                if (ipaus.le.iddln) then
  283.                   write(ioimp,*) 'Erreur numerotation'
  284.                   write(ioimp,*) 'iddl,iddln,ipaus=',iddl,iddln,ipaus
  285.                   goto 9999
  286.                endif
  287.             elseif (ityp.gt.0) THEN
  288.                if (ipaur.ge.iddln) then
  289.                   write(ioimp,*) 'Erreur numerotation'
  290.                   write(ioimp,*) 'iddl,iddln,ipaur=',iddl,iddln,ipaur
  291.                   goto 9999
  292.                endif
  293.             else
  294.                write(ioimp,*) 'ityp=0 pas normal pour un lagrange'
  295.                goto 9999
  296.             endif
  297.  1700    continue
  298.       ENDIF
  299. *
  300. *     Menage
  301. *
  302.       SEGSUP JORDRE
  303.       SEGSUP LAGRAN
  304.       SEGSUP KTYP
  305.       SEGSUP,JPERM
  306. *      iperm=jperm
  307.       write(ioimp,*) 'FIN KRES24'
  308.       if (ldbnum) segprt,nnutot
  309.       if (ldbnum) segprt,iperm
  310. C
  311. C     Normal termination
  312. C
  313.       RETURN
  314. C
  315. C     Error Handling
  316. C
  317.  9999 CONTINUE
  318.       MOTERR(1:8)='KRES24  '
  319.       CALL ERREUR(1127)
  320.       RETURN
  321. C
  322. C     Format handling
  323. C
  324.  2022 FORMAT(10(1X,1PG12.5))
  325. C
  326. C     End of subroutine KRES24
  327. C
  328.       END
  329.  
  330.  

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