Télécharger la plaquette Cast3M


fr en

Télécharger chole1.eso

Retour à la liste

Numérotation des lignes : 

  1. C CHOLE1    SOURCE    GF238795  18/02/01    21:15:04     9724           
  2.       FUNCTION CHOLE1(ILIGF,LIGN,VALF,DAAG,IPKNO,IPPVF,KHG,IVPOF,
  3.      # KIDEP,KI1,KQ,imasq,idep,prec,nbo)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6. -INC SMMATRI
  7. -INC CCHOLE
  8.       DIMENSION ILIGF(*),VALF(*),DAAG(*),IPKNO(*),IPPVF(*),IVPOF(*)
  9.       dimension imasq(1)
  10.       IPPKHG=IPPVF(KHG)
  11.       KBAS=IPKNO(KIDEP)
  12.       KHAU=IPKNO(KI1)
  13.       KDIAG=KI1+1
  14.       DNORM=ABS(VALF(KDIAG))*PREC
  15.       KPREM=IVPOF(KHG)-IPPKHG
  16.       DO 10 K=KBAS,KHAU
  17.        LIG1=ILIGF(K)
  18.        IF (LIG1.EQ.LIGN) GOTO 20
  19.        IECAR=KQ-LIG1.IPREL+1
  20.        ICA=MAX(1,KIDEP+IECAR)
  21.        ICB=LIG1.IMMM(/1)
  22.        CALL CHOLE2(LIG1.IPPVV(1),VALF(1),LIG1.VAL(1),LIG1.IVPO(1),
  23.      >  imasq(1),idep,prec,ica,icb,iecar,kprem,dnorm)
  24.   10  CONTINUE
  25.       GOTO 50
  26.   20  CONTINUE
  27.       IECAR=KQ-IPREL+1
  28.       DO 30 NNJ=MAX(1,KIDEP+IECAR),KI1+IECAR
  29.        KK=NNJ-IECAR
  30.        NNJJ=IPPVF(NNJ+1)
  31.        NJ=NNJJ-IPPVF(NNJ)
  32.        LLOL=MIN(NJ,KK)-1
  33.        LLON=MIN(LLOL-KK+KPREM+1,LLOL-NNJJ+IVPOF(NNJ)+1)
  34.        IF (LLON.GT.0.and.kk.ge.1) THEN
  35.         IEC1=KK-LLOL-1
  36.         IEC2=NNJJ-IPPKHG-KK
  37.         ideq=1+iec1+idep-1
  38.         if (llon.gt.masdim+1) then
  39.         p=ddotpw(llon,VALF(1+iec1),VALF(1+iec1+iec2),
  40.      >     imasq(1),1+idep-1,nbo)
  41.         else
  42. **       if (imasq(ideq/masdim+1).gt.0.or.
  43. **   >       imasq((ideq+llon)/masdim+1).gt.0)
  44.          p=ddotpv(llon,VALF(1+iec1),VALF(1+iec1+iec2))
  45. c         if (llon.ge.1) nc=nc+llon
  46.         endif
  47.         VALF(KK)=VALF(KK)-P
  48.         IF (ABS(VALF(KK)).GT.DNORM) then
  49.          KPREM=KK
  50.          imasq((kk+idep-1)/masdim+1) =1
  51. *  si on remonte, on tombe au terme diagonal ou apres, mais ce n'est qu'un seul terme
  52.          imasq(kk/masdim+1) =1
  53.         ELSE
  54. *  annuler le terme car on l'ignorera par la suite
  55.          valf(kk)=0.d0
  56.         ENDIF
  57.        ENDIF
  58.   30  CONTINUE
  59.   50  CONTINUE
  60.       AUX1=0.D0
  61.       kdeb=1
  62.   43  continue
  63.       kdebi=kdeb
  64.   44  continue
  65.       do 100 im=kdeb/masdim+1,kprem/masdim+1
  66.          jm=imasq(im)
  67.          if (jm.gt.0) goto 105
  68.          if (jm.eq.0) goto 100
  69.          jinio=-jm/masdim+1
  70.         if (jinio.gt.im+7) then
  71. *         write (6,*) 'saut kdeb jm ',kdeb,jm
  72.           kdeb=-jm
  73.           goto 44
  74.         endif
  75.  100  continue
  76.  105  continue
  77.       ideb=max((im-1)*masdim,kdebi)
  78.       do 110 im=ideb/masdim+1,kprem/masdim+1
  79.          if (imasq(im).le.0) goto 115
  80.  110  continue
  81.  115  continue
  82.       im=im-1
  83.       ifin=min((im)*masdim-1,kprem)
  84. **    write (6,*) ' chole1 kdeb kprem ideb ifin ',kdeb,kprem,ideb,ifin
  85.       DO 9 K=ideb,ifin
  86.        AUX=VALF(K)
  87.        VALF(K)=AUX/DAAG(K)
  88.        AUX1=AUX1+AUX*VALF(K)
  89.    9  CONTINUE
  90.       if (ifin.lt.kprem) then
  91.        kdeb=ifin+1
  92.        goto 43
  93.       endif
  94.       ivpof(khg)=kprem+ippkhg
  95.       CHOLE1=-AUX1
  96.       RETURN
  97.       END
  98.  
  99.  
  100.  
  101.  
  102.  
  103.  
  104.  
  105.  
  106.  
  107.  
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  

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