C GRACO3 SOURCE PV090527 23/03/08 12:22:20 11617 FUNCTION GRACO3(ILIGF,LIGN,VALF,DAAG,IPKNO,IPPVF,KHG,IVPOF, # KIDEP,KI1,KQ,imasq,idep,prec,ittrl,nc) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C C COPIE DE CHOLE1 POUR FAIRE UN CHOLEVSKI INCOMPLET C -INC SMMATRI -INC CCHOLE DIMENSION ILIGF(1),VALF(1),DAAG(1),IPKNO(1),IPPVF(1),IVPOF(1) dimension imasq(1),ittrl(1) IPPKHG=IPPVF(KHG) KBAS=IPKNO(KIDEP) KHAU=IPKNO(KI1) KDIAG=KI1+1 kndiag=ipkno(kdiag) DNORM=ABS(VALF(KDIAG))*PREC KPREM=IVPOF(KHG)-IPPKHG incomp=1 if (ittrl(iprel-1+khg).ne.0) incomp=0 DO 10 K=KBAS,KHAU if (kndiag-k.lt.1) incomp=0 LIG1=ILIGF(K) IF (LIG1.EQ.LIGN) GOTO 20 IECAR=KQ-LIG1.IPREL+1 ICA=MAX(1,KIDEP+IECAR) ICB=LIG1.IMMM(/1) CALL GRACO4(LIG1.IPPVV(1),VALF(1),LIG1.VAL(1),LIG1.IVPO(1), > imasq(1),idep,prec,ica,icb,iecar,kprem,dnorm,incomp, > lig1.iderl,ittrl(1),nc) 10 CONTINUE GOTO 50 20 CONTINUE IECAR=KQ-IPREL+1 DO 30 NNJ=MAX(1,KIDEP+IECAR),KI1+IECAR KK=NNJ-IECAR NNJJ=IPPVF(NNJ+1) if (valf(kk).eq.0.d0.and.incomp.eq.1.and. > ittrl(iderl-ki1+kk).eq.0)goto 31 NJ=NNJJ-IPPVF(NNJ) LLOL=MIN(NJ,KK)-1 LLON=MIN(LLOL-KK+KPREM+1,LLOL-NNJJ+IVPOF(NNJ)+1) IF (LLON.GT.0) THEN P=0.D0 IEC1=KK-LLOL-1 IEC2=NNJJ-IPPKHG-KK ideq=1+iec1+idep-1 if (llon.gt.masdim+1) then p=ddotpw(llon,VALF(1+iec1),VALF(1+iec1+iec2), > imasq(1),ideq,nc) else if (imasq(ideq/masdim+1).gt.0.or. > imasq((ideq+llon)/masdim+1).gt.0) > p=ddotpv(llon,VALF(1+iec1),VALF(1+iec1+iec2)) nc=nc+llon endif VALF(KK)=VALF(KK)-P ENDIF 31 continue IF (ABS(VALF(KK)).GT.DNORM) then KPREM=KK imasq((kk+idep-1)/masdim+1) =1 ENDIF 30 CONTINUE 50 CONTINUE AUX1=0.D0 kdeb=1 43 continue km1=0 im=1 DO 9 K=kdeb,KPREM km=(k+idep-1)/masdim+1 if (km.ne.km1) then km1=km im=imasq(km) endif if (im.eq.0) goto 9 if (im.lt.0) then imr=-im-idep+1 if (imr.gt.k+jacc) then kdeb=imr * write (6,*) ' k kdeb ',k,imasq(km) GOTO 43 else goto 9 endif ENDIF AUX=VALF(K) if (aux.ne.0.d0) then VALF(K)=AUX*DAAG(K) AUX1=AUX1+AUX*VALF(K) endif 9 CONTINUE IVPOF(KHG)=KPREM+IPPKHG DO 8 K=KPREM+1,KI1 VALF(K)=0.D0 8 CONTINUE GRACO3=-AUX1 RETURN END