Sources Esope | Cast3M

resou1
C RESOU1    SOURCE    MB234859  25/01/03    21:15:25     12105          
      SUBROUTINE RESOU1(KRIGI,IDAMEM,NOID,NOEN,prec,istab,isouci)
C
C **** SUBROUTINE QUI EXECUTE L OPERATION RESOU
C **** APPELEE PAR RESOU OU PAR SUPRI
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER OOOVAL
      SEGMENT IDEMEM(0)
-INC SMRIGID
-INC SMVECTD
 
-INC PPARAM
-INC CCOPTIO
-INC SMMATRI
C
      MRIGID=KRIGI
      SEGACT MRIGID
      LAGDUA=IMLAG
      ICHOLX=ICHOLE
      SEGDES MRIGID
      IF(ICHOLX.NE.0) then
       MMATRI=ICHOLX
       SEGACT MMATRI
       IF (PRCHLV.lt.PREC*1.001.and.PRCHLV.gt.PREC*0.999) GO TO 1
       write (6,*) ' attention changement de precision '
       MILIGN=IILIGN
       segact milign
       DO 20 I=1,ILIGN(/1)
        LIGN=ILIGN(I)
        SEGSUP LIGN
  20   CONTINUE
       MDIAG=IDIAG
       SEGSUP MDIAG
       MDNOR=IDNORM
       SEGSUP MDNOR
       SEGSUP MMATRI
       ICHOLX=0
      ENDIF
      CALL TRIANG(KRIGI,prec,istab)
      IF(IERR.NE.0) GO TO 5000
      MRIGID=KRIGI
      SEGACT MRIGID
      ICHOLX=ICHOLE
      SEGDES MRIGID
      mmatri=icholx
      segact mmatri
C
C **** SUBROUTINE CHV2 : TRANSFORME LE CHPOIN ISECO EN VECTEUR
C
 1    CONTINUE
      IDEMEM=IDAMEM
      SEGACT IDEMEM*MOD
      NNTOT=IDEMEM(/1)
      MMATRI=ICHOLX
      SEGACT MMATRI
      MILIGN=IILIGN
      SEGACT,MILIGN
      INK=IPNO(/1)
      SEGDES MILIGN,MMATRI
      CALL INTPDO(LENB)
      NNPA= MAX(1,((OOOVAL(1,1)-NGMAXY)/(2*LENB))/INK+1)
 
C
C  ON TRAVAILLE AVEC AUTANT DE VECTEUR SIMULTANEE QU'IL EN RENTRE DANS
C  LA MOITIE DE LA MEMOIRE CENTRALE
C
      NN=NNPA
      DO 201 KGEN = 1,NNTOT,NNPA
      IF(KGEN+NNPA-1.GT.NNTOT)  NN= NNTOT-KGEN+1
      KGEN1=KGEN-1
      DO 2 K=1,NN
      ISECO=IDEMEM(K+KGEN1)
      CALL CHV2(ICHOLX,ISECO,MVECTX,NOID)
      IF(IERR.NE.0) GO TO 5000
      IDEMEM(K+KGEN1)=MVECTX
   2  CONTINUE
      IF(NN.NE.1) THEN
         INC = INK * NN
         SEGINI MVECTD
         DO 3 LL=1,NN
         LD=INK*(LL-1)
         MVECT1=IDEMEM(LL+KGEN1)
         SEGACT MVECT1
         DO  L=1,INK
         VECTBB(L+LD)=MVECT1.VECTBB(L)
         enddo
         SEGSUP MVECT1
    3    CONTINUE
         MVECTX=MVECTD
         SEGDES MVECTD
      ENDIF
C
C **** SUBROUTINE MONDES :
C
      IF(IIMPI.EQ.1) THEN
         WRITE(IOIMP,499)
 499     FORMAT('  TEMPS SUIVANT  AVANT APPEL MONDES')
         CALL GIBTEM(XKT)
         INTERR(1)=XKT
         CALL ERREUR(-259)
      ENDIF
      segact mrigid
**    write(6,*) 'dans resou1 mrigid lagdua ',mrigid,lagdua
      CALL MONDES(ICHOLX,MVECTX,NOEN,isouci,lagdua)
      IF(IIMPI.EQ.1) THEN
         WRITE(IOIMP,498)
 498     FORMAT('  TEMPS SUIVANT  APRES APPEL MONDES')
         CALL GIBTEM(XKT)
         INTERR(1)=XKT
         CALL ERREUR(-259)
      ENDIF
      IF(IERR.NE.0) GO TO 5000
C
C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT
C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE
C
      MVECTA=MVECTX
      DO 5 K=1,NN
      IF(NN.EQ.1) GO TO 10
      IF(K.EQ.1) THEN
         INC=INK
         MVECT1=MVECTX
         SEGACT MVECT1
         SEGINI MVECTD
      ENDIF
      SEGACT MVECTD*MOD
      LD=(K-1)*INK
      DO 6 L=1,INK
      VECTBB(L)=MVECT1.VECTBB(L+LD)
    6 CONTINUE
      MVECTA=MVECTD
      SEGDES MVECTD
      IF(K.EQ.NN) SEGSUP MVECT1
   10 CONTINUE
      CALL VCH1(ICHOLX,MVECTA,ISOLU,KRIGI)
      IF(IERR.NE.0) RETURN
C
      IDEMEM(K+KGEN1)=ISOLU
   5  CONTINUE
      MVECTD=MVECTA
      SEGSUP  MVECTD
  201 CONTINUE
      IDAMEM = IDEMEM
****  SEGDES IDEMEM
C
 5000 CONTINUE
      RETURN
      END