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

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