Sources Esope | Cast3M

rezolu
C REZOLU    SOURCE    GOUNAND   22/08/25    21:15:11     11434          
      SUBROUTINE REZOLU(IDMAT,
     $     KS2B,
     $     IMPR,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C************************************************************************
C
C    RESOLUTION (MONTEE DESCENTE) D'UNE MATRICE SYMETRIQUE OU NON
C    PRECEDEMMENT TRIANGULEE PAR TRIAKS
C
C    POINTEUR : EN ENTREE MATRIK CONTIENT LA MATRICE TRIANGULEE
C      B  CONTIENT LE SECOND MEMBRE
C      EN SORTIE B  CONTIENT LA SOLUTION
C
C    VERSION OPTIMISEE EN GESTION MEMOIRE POUR LES TRES GROSSES
C    MATRICES. ON UTILISE L'ALGORITHME MRU (AVEC LA MODIFICATION
C    DANS OOOMWD) POUR LES BLOCS DE LA MATRICE. CECI EVITE DE TRANSFERER
C    SUR DISQUE LE RESTE DU CONTENU DE LA MEMOIRE, I.E. LES TABLEAUX
C    VITESSE, TEMPERATURE, ETC... QUI AURAIENT A ETRE RAPPELES DES
C    LA RESOLUTION TERMINEE.
C
C************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMMATRIK
      POINTEUR KS2B.IZA
      POINTEUR ISAL.IZA
      POINTEUR ISAU.IZA
*STAT-INC SMSTAT
      SEGMENT IZD
      REAL*8 D(1)
      ENDSEGMENT
*
      INTEGER IMPR,IRET
* Fonctions
      REAL*8 DDOT
*
* Executable statements
*
      IF (IMPR.GT.5) WRITE(IOIMP,*) 'Entrée dans rezolu'
*STAT      CALL INMSTA(MSTAT,1)
      SEGACT IDMAT
      SEGACT KS2B*MOD
      NBLK=IDESCL(/1)
C Descente
      IZD=IDIAG
      SEGACT IZD
      NTT=KS2B.A(/1)
      CALL OOOMRU(1)
      DO 305 IBLK=1,NBLK
* Gestion du CTRL-C
         if (ierr.NE.0) return
         KJD=NLDBLK(IBLK)
         IF(IBLK.EQ.1)KJD=2
         KJF=NLDBLK(IBLK+1)-1
         ISAL=IDESCL(IBLK)
         SEGACT ISAL
         DO 300 N=KJD,KJF
            KDEB=N-KZA(N)+1
            LA=KZA(N)-1
            IDECI=NUIA(N,2)
            IF (LA.NE.0) THEN
                US=DDOT(LA,ISAL.A(IDECI+1),1,KS2B.A(KDEB),1)
            ELSE
                US=0.D0
            ENDIF
            KS2B.A(N)=(KS2B.A(N)-US)
 300     CONTINUE
         SEGDES ISAL*MRU
 305  CONTINUE
C      segact KS2B
C      WRITE(IOIMP,*) 'Descente'
C      WRITE(IOIMP,*) 'KS2B'
C      WRITE (IOIMP,2022) (KS2B.A(II),II=1,KS2B.A(/1))
C 2022 FORMAT(10(1X,1PG12.5))
 
*STAT      CALL PRMSTA('Descente',MSTAT,1)
      CALL DIVISE(NTT,KS2B.A,KS2B.A,D)
      SEGDES IZD*MRU
*STAT      CALL PRMSTA('Division',MSTAT,1)
C Remontee
      DO 304 KBLK=1,NBLK
* Gestion du CTRL-C
         if (ierr.NE.0) return
         IBLK=NBLK-KBLK+1
         KJD=NLDBLK(IBLK)
         KJF=NLDBLK(IBLK+1)-1
         ISAU=IDESCU(IBLK)
         SEGACT ISAU
         DO 302 N=KJF,KJD,-1
            KDEB=N-KZA(N)
            SA=-KS2B.A(N)
            I0=NUIA(N,2)
            LGL=KZA(N)-1
            IF (LGL.NE.0)
     >      CALL DAXPY(LGL,SA,ISAU.A(I0+1),1,KS2B.A(KDEB+1),1)
 302     CONTINUE
         SEGDES ISAU*MRU
 304  CONTINUE
      CALL OOOMRU(0)
      SEGDES KS2B
      SEGDES IDMAT
*STAT      CALL PRMSTA('Remontée',MSTAT,1)
*
* Normal termination
*
      IRET=0
      RETURN
*
* Format handling
*
*
* Error handling
*
 9999 CONTINUE
      IRET=1
      WRITE(IOIMP,*) 'An error was detected in subroutine rezolu'
      RETURN
*
* End of subroutine REZOLU
*
      END