Télécharger la plaquette Cast3M


fr en

Télécharger kres14.eso

Retour à la liste

Numérotation des lignes : 

kres14

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

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