Télécharger la plaquette Cast3M


fr en

Télécharger graco0.eso

Retour à la liste

Numérotation des lignes : 

graco0

  1. C GRACO0    SOURCE    MB234859  26/06/10    21:15:30     12569          
  2.       SUBROUTINE GRACO0(KRIGI,IDAMEM,NOID,NOEN,prec,istab)
  3. C
  4. C **** SUBROUTINE QUI EXECUTE L OPERATION RESOU PAR GRADIENT CONJUGUE
  5. C **** APPELEE PAR GRACO
  6. C
  7.       IMPLICIT INTEGER(I-N)
  8.       REAL*8 XKT
  9.       INTEGER OOOVAL
  10.       SEGMENT IDEMEM(0)
  11. -INC SMRIGID
  12. -INC SMVECTD
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMMATRI
  16. C
  17.       IGRADJ=1
  18.       MRIGID=KRIGI
  19.       SEGACT MRIGID
  20.       ICHOLX=ICHOLE
  21.       SEGDES MRIGID
  22.       IF (ICHOLX.NE.0) THEN
  23.         MMATRI=ICHOLX
  24.         SEGACT,MMATRI
  25.       ELSE
  26.         CALL TRIANG(KRIGI,prec,istab,igradj)
  27.         IF(IERR.NE.0) GOTO 5000
  28.         MRIGID=KRIGI
  29.         SEGACT MRIGID
  30.         ICHOLX=ICHOLE
  31.         SEGDES MRIGID
  32.       ENDIF
  33. C
  34. C **** SUBROUTINE CHV2 : TRANSFORME LE CHPOIN ISECO EN VECTEUR
  35. C
  36.       IDEMEM=IDAMEM
  37.       SEGACT IDEMEM*MOD
  38.       NNTOT=IDEMEM(/1)
  39.       MMATRI=ICHOLX
  40.       SEGACT MMATRI
  41.       MILIGN=IILIGN
  42.       SEGACT,MILIGN
  43.       INK=IPNO(/1)
  44.       SEGDES MILIGN,MMATRI
  45.       CALL INTPDO(LENB)
  46.       NNPA= MAX(1,((OOOVAL(1,1)-NGMAXY)/(2*LENB))/INK+1)
  47. C
  48. C  ON TRAVAILLE AVEC AUTANT DE VECTEUR SIMULTANEE QU'IL EN RENTRE DANS
  49. C  LA MOITIE DE LA MEMOIRE CENTRALE
  50. C
  51.       NN=NNPA
  52.       DO 201 KGEN = 1,NNTOT,NNPA
  53.       IF(KGEN+NNPA-1.GT.NNTOT)  NN= NNTOT-KGEN+1
  54.       KGEN1=KGEN-1
  55.       DO 2 K=1,NN
  56.       ISECO=IDEMEM(K+KGEN1)
  57.       CALL CHV2(ICHOLX,ISECO,MVECTX,NOID)
  58.       IF(IERR.NE.0) GOTO 5000
  59.       IDEMEM(K+KGEN1)=MVECTX
  60.    2  CONTINUE
  61.       IF(NN.NE.1) THEN
  62.          INC = INK * NN
  63.          SEGINI MVECTD
  64.          DO 3 LL=1,NN
  65.          LD=INK*(LL-1)
  66.          MVECT1=IDEMEM(LL+KGEN1)
  67.          SEGACT MVECT1
  68.          DO   L=1,INK
  69.          VECTBB(L+LD)=MVECT1.VECTBB(L)
  70.          ENDDO
  71.          SEGSUP MVECT1
  72.     3    CONTINUE
  73.          MVECTX=MVECTD
  74.          SEGDES MVECTD
  75.       ENDIF
  76. C
  77. C **** SUBROUTINE GRACO6 :
  78. C
  79.       IF(IIMPI.EQ.1) THEN
  80.          WRITE(IOIMP,499)
  81.  499     FORMAT('  TEMPS SUIVANT AVANT APPEL GRACO6')
  82.          CALL GIBTEM(XKT)
  83.          INTERR(1)=XKT
  84.          CALL ERREUR(-259)
  85.       ENDIF
  86.       CALL GRACO6(ICHOLX,MVECTX,NOEN,MSOL,lenb)
  87.       IF(IIMPI.EQ.1) THEN
  88.          WRITE(IOIMP,498)
  89.  498     FORMAT('  TEMPS SUIVANT APRES APPEL GRACO6')
  90.          CALL GIBTEM(XKT)
  91.          INTERR(1)=XKT
  92.          CALL ERREUR(-259)
  93.       ENDIF
  94.       IF(IERR.NE.0) GOTO 5000
  95. C
  96. C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT
  97. C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE
  98. C
  99.       MVECTA=MSOL
  100.       DO 5 K=1,NN
  101.       IF(NN.EQ.1) GO TO 10
  102.       IF(K.EQ.1) THEN
  103.          INC=INK
  104.          MVECT1=MSOL
  105.          SEGACT MVECT1
  106.          SEGINI MVECTD
  107.       ENDIF
  108.       SEGACT MVECTD
  109.       LD=(K-1)*INK
  110.       DO 6 L=1,INK
  111.       VECTBB(L)=MVECT1.VECTBB(L+LD)
  112.     6 CONTINUE
  113.       MVECTA=MVECTD
  114.       SEGDES MVECTD
  115.       IF(K.EQ.NN) SEGSUP MVECT1
  116.    10 CONTINUE
  117.       CALL VCH1(ICHOLX,MVECTA,ISOLU,KRIGI)
  118.       IF(IERR.NE.0) RETURN
  119. C
  120.       IDEMEM(K+KGEN1)=ISOLU
  121.    5  CONTINUE
  122.       MVECTD=MVECTA
  123.       SEGSUP  MVECTD
  124.   201 CONTINUE
  125.       IDAMEM = IDEMEM
  126.       SEGDES IDEMEM
  127. C
  128.  5000 CONTINUE
  129.       RETURN
  130.       END
  131.  
  132.  

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