C LDMT3 SOURCE PV090527 26/01/19 21:15:23 12456 SUBROUTINE LDMT3(MMATRX,PREC) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C TANT QUE OOOVAL(1,4) NE MARCHE PAS SUR CRAY PARAMETER (LPCRAY=10000) INTEGER OOOVAL,OOOLEN dimension ittime(4) POINTEUR LIG2.LIGN, LIG3.LIGN POINTEUR L.LLIGN, M.LLIGN POINTEUR LL.MILIGN, MM.MILIGN, LILIGN.MILIGN POINTEUR LLL.LIGN, MMM.LIGN SEGMENT ITEMP REAL*8 P(INC) ENDSEGMENT C POINTEUR R.ITEMP,W.ITEMP C C **** MISE SOUS FORME A=L D Mt DE LA MATRICE MMATRX C -INC PPARAM -INC CCOPTIO -INC CCREEL -INC SMMATRI -INC CCASSIS -INC CCHOLE SEGMENT KIVPO(IIMAX) SEGMENT KIVLO(IIMAX) segment immt(nblig) segment ireser(nvstrm) external chole3i SAVE IPASV DATA IPASV/0/ * ngmpet dit si on tient en memoire (false) ou si on deborde (true) logical ngmpet C character*8 zen C equivalence (zen,izen) logical lsgdes,pasfait,ngdyn ** xkpar=0 ** xkseq=0 ireser=0 matric=0 maitre=0 pasfait=.true. lsgdes=.false. * faire attention a respecter l'ordre des segdes par la suite call ooomru(1) condmax=0.d0 condmin=xgrand ngmpet=.false. ngdyn=.true. call timespv(ittime,oothrd) kcour=(ittime(1)+ittime(2))/10 kcourp=kcour kcouri=kcour kdiff=0 kcour=0 perf=0.d0 perfp=-1 nbchan=1 nbopit=0 iposm=0 C zen='CPU'//char(0) C le=4 nvaor=0 nbthro=nbthrs ithrd=0 if (nbthro.gt.1) then ithrd=1 call threadii call oooprl(1) endif nbthr=nbthro do ith=1,nbthr nbop(ith)=0 enddo stmult=1d-5 C nouvelle methode de gestion de l'espace memoire necessitee par la parallelisation C memoire vive totale MACTIT=OOOVAL(1,1) ** write(6,*) ' mactit igrand ',mactit,igrand C un bloc de memoire fera au plus macti/2 call intpdo(inpdo) nvstrm=mactit/10 MMATRI=MMATRX SEGACT,MMATRI*MOD PRCHLV=PREC LL =IILIGN MM =IILIGS SEGACT, MM*MOD,LL*MOD INO=MM.ILIGN(/1) MDIAG=IDIAG SEGACT,MDIAG*MOD NBLIG=INO NBLIGI=INO segini immt precc=prec INC=DIAG(/1) nbnnmc=inc+1 nvstrm=max(inc*inpdo,nvstrm) ** write(6,*) ' nvstrm ',nvstrm INCC=INC MIMIK=IIMIK MINCPO=IINCPO SEGACT,MINCPO,MIMIK IPLUMI=IMIK(/2)*2 +4 IL2=0 IIMAX=IJMAX+IPLUMI SEGINI KIVPO,KIVLO INEG=0 NBLAG=0 NENSLX=0 NVSTOC=0 NVSTOR=0 NVSTIC=0 NVSTIR=0 diagmax=XPETIT/XZPREC diagmin=xgrand do i=1,diag(/1) if (ll.ittr(i).eq.0) diagmax=max(diagmax,abs(diag(i))) if (ll.ittr(i).eq.0.and.abs(diag(i)).gt.xpetit/xzprec) > diagmin=min(diagmin,abs(diag(i))) enddo if (diagmax.le.xpetit/xzprec) then do i=1,diag(/1) diagmax=max(diagmax,abs(diag(i))) if (abs(diag(i)).gt.xpetit/xzprec) > diagmin=min(diagmin,abs(diag(i))) enddo endif diagmin=min(diagmin,diagmax) *** write (6,*) ' ldmt3 diagmin diagmax ',diagmin,diagmax,diag(/1) C C C C **** DEBUT DE LA TRIANGULARISATION. ON PREND NOEUD A NOEUD, C **** DECOMPACTAGE PUIS TRAVAIL SUR LES LIGNES DU NOEUDS C C **** LA LONGUEUR DE LA PLUS GRANDE LIGNE EST DONNEE PAR IMAX C 1 CONTINUE IVALMA=IJMAX+IPLUMI IL1=IL2+1 IVALMI=IJMAX+IPLUMI IMINM=IL1 IMINL=IL1 * reserver de la place ou mettre les lignes superieures dans le cas debordement if (ngmpet) then if(ireser.eq.0) segini ireser endif DO 2 I=IL1,INO ngdyn=.true. m=0 l=0 lll=0 mmm=0 M = MM.ILIGN(I) L = LL.ILIGN(I) SEGACT /ERR=32/M SEGACT /ERR=32/L goto 31 32 continue ** write(6,*) ' segact llign erreur',i,il1,lsgdes if (.not.lsgdes) then ** write(6,*) ' lsgdes 1 ' lsgdes=.true. **** ngmpet=.true. ** write(6,*) 'desactivation-1 ',1,il1-1 do it=il1-1,1,-1 lign=mm.ilign(it) segdes lign lign=ll.ilign(it) segdes lign enddo else goto 3 endif SEGACT /ERR=3/M SEGACT /ERR=3/L 31 continue NA= M.IMMMM(/1) C* write (6,*) ' chole ligne noeud inconnues ',i,ipno(i),na NBPAR=NA+1 NVALL=M.NJMAX LMASQ=masqa(NVALL)+1 lmasqm=lmasq NVALLL=NVALL mmm=0 lll=0 SEGINI /ERR=33/MMM NA=L.IMMMM(/1) NBPAR=NA+1 NVALL= L.NJMAX LMASQ=masqa(NVALL)+1 lmasql=lmasq NVILL=NVALL lll=0 SEGINI /ERR=33/LLL C recuperer la longueur du segment lglig=na*(nvall/na)**1.33333333333333333333333333 goto 34 33 continue ** write(6,*) ' segini xx.llign erreur',i,il1 if (mmm.ne.0) segsup mmm if (.not.lsgdes) then ** write(6,*) ' lsgdes 2 ' lsgdes=.true. **** ngmpet=.true. ** write(6,*) 'desactivation-2 ',1,il1-1 do it=il1-1,1,-1 lign=mm.ilign(it) segdes lign lign=ll.ilign(it) segdes lign enddo else goto 3 endif SEGINI /ERR=33/MMM SEGINI /ERR=33/LLL 34 continue C recuperer la longueur du segment lglig=na*(nvall/na)**1.33333333333333333333333333 NVSTOC=NVSTOC + NVALLL IVALMA=IVALMA + NVALLL NVSTIC=NVSTIC + NVALL IVALMI=IVALMI + NVALL NVALL=NVALLL nvaor = nvaor + M.XXVA(/1) nvaori= nvaori+ L.XXVA(/1) C C **** DECOMPACTAGE C IPA=1 NA=M.IMMMM(/1) DO 121 JPA=1,NA MMM.IVPO(JPA)=IPA KPA = M.IPPO(JPA+1)-M.IPPO(JPA) IPP = M.IPPO(JPA) MMM.IPPVV(JPA)=IPA-1 LPA = M.LDEB(JPA) LPA1 = LPA-IPA DO 122 MPA=1,KPA LLO = M.LINC(MPA+IPP) IPLA = LLO -LPA1 xxv=m.xxva(mpa+ipp) if(abs(xxv).gt.xpetit) then MMM.VAL(IPLA)=xxv MMM.IMASQ(masqa(IPLA))=1 if (ipla-ipa+1.ge.1) MMM.IMASQ(masqa(IPLA-ipa+1))=1 endif 122 CONTINUE IPA=IPA+M.IMMMM(JPA)-LPA + 1 Cpv MMM.IMMM(JPA)=MM.IPNO(LPA) MMM.IMMM(JPA)=LPA IF(IMINM .GT.MM.IPNO(LPA )) IMINM = MM.IPNO(LPA) 121 CONTINUE * indexation de imasq ipln=lmasq/na iplp=lmasq/na ** write (6,*) 'ldmt3 271 lmasq imasq ',lmasq,mmm.imasq(/1) do 123 ipl=lmasqm/na,1,-1 if (mmm.imasq(ipl).gt.0) then mmm.imasq(ipl)=masqi(iplp+1) ipln=ipl-1 else mmm.imasq(ipl)=-masqi(ipln+1) iplp=ipl-1 endif 123 continue ** write (6,*) ' imasq ',lmasq/na ** write (6,*) (imasq(ipl),ipl=1,lmasq/na) IPI=1 NA=L.IMMMM(/1) DO 1210 JPA=1,NA LLL.IVPO(JPA)=IPI KPI =L.IPPO(JPA+1)-L.IPPO(JPA) IPPI=L.IPPO(JPA) LLL.IPPVV(JPA)=IPI-1 LPAI =L.LDEB(JPA) LPA1I=LPAI-IPI DO 1220 MPA=1,KPI LLO=L.LINC(MPA+IPPI) IPLA=LLO-LPA1I xxv=l.xxva(mpa+ippi) if(abs(xxv).gt.xpetit) then LLL.VAL(IPLA)=xxv LLL.IMASQ(masqa(IPLA))=1 if (ipla-ipi+1.ge.1) LLL.IMASQ(masqa(IPLA-ipi+1))=1 endif 1220 CONTINUE IPI=IPI+L.IMMMM(JPA)-LPAI+ 1 Cpv LLL.IMMM(JPA)=LL.IPNO(LPAI) LLL.IMMM(JPA)=LPAI IF(IMINL.GT.LL.IPNO(LPAI)) IMINL= LL.IPNO(LPAI) 1210 CONTINUE C*** **** **** * indexation de imasq ipln=lmasq/na iplp=lmasq/na ** write (6,*) 'ldmt3 314 lmasq imasq ',lmasq,lll.imasq(/1) do 1230 ipl=lmasql/na,1,-1 if (lll.imasq(ipl).gt.0) then lll.imasq(ipl)=masqi(iplp+1) ipln=ipl-1 else lll.imasq(ipl)=-masqi(ipln+1) iplp=ipl-1 endif 1230 continue ** write (6,*) ' imasqa ',lmasq/na ** write (6,*) (imasqa(ipl),ipl=1,lmasq/na) NA=M.IMMMM(/1) if (NA.gt.0) then MMM.IPREL=M.IMMMM(1) MMM.IDERL=M.IMMMM(NA) mm.lcara(2,i)=mmm.iprel mm.lcara(3,i)=mmm.iderl endif MMM.IPPVV(NA+1)=IPA-1 NA=L.IMMMM(/1) if (NA.gt.0) then LLL.IPREL=L.IMMMM(1) LLL.IDERL=L.IMMMM(NA) ll.lcara(2,i)=lll.iprel ll.lcara(3,i)=lll.iderl endif LLL.IPPVV(NA+1)=IPI-1 SEGSUP L,M LL.ILIGN(I)=LLL MM.ILIGN(I)=MMM C* write (6,*) 'longueur ligne ',nvall C nb de ligne multiple du nb de threads C blocage ligne lecture-ecriture pour minimiser le cache C on note si on est au minimum de lignes nbthro=min(nbthrs,lglig/1200+1) if (i+1-il1.ge.nbthro.and.(.not.ngmpet)) then nbthro=min(nbthrs,i+1-il1) ngdyn=.true. if(i+1-il1.eq.nbthrs) ngdyn=.false. il2=i GOTO 4 endif 2 CONTINUE IL2=INO GO TO 4 3 IL2=I-1 if(m.ne.0) segdes m if(l.ne.0) segdes l if (lll.ne.0) segsup lll if (mmm.ne.0) segsup mmm 4 CONTINUE nbthro=min(nbthrs,nbthro) nbthr=nbthro if(ireser.ne.0) segsup ireser C WRITE(IOIMP,*) 'Mactic = ', mactic, nbthr C IF(IL2.GE.IL1) GO TO 40 C C **** APPEL AUX ERREURS MESSAGE PAS ASSEZ DE PLACE MEMOIRE C C ITYP=48 CALL ERREUR(48) call ooodmp(0) if (ithrd.eq.1) then call threadis call oooprl(0) endif call ooomru(0) RETURN 40 CONTINUE IM=INC DO 352 IH=IL2,IL1,-1 MMM=MM.ILIGN(IH) IL=INC DO 354 JH=1,MMM.IMMM(/1) IM=MIN(IM,MMM.IMMM(JH)) IL=MIN(IL,MMM.IMMM(JH)) 354 CONTINUE MMM.IML=IL mm.lcara(1,iH)=IL MMM.IMM=MM.ipno(IM) if (immt(ih).ne.0) then immt(ih)=min(immt(ih),mm.ipno(IM)) else immt(ih)=mm.ipno(IM) endif 352 CONTINUE C 353 CONTINUE MMM=MM.ILIGN(IL1) IL11=MMM.IPREL IM=INC DO 3520 IH=IL2,IL1,-1 LLL=LL.ILIGN(IH) IL=INC DO 3540 JH=1,LLL.IMMM(/1) IM=MIN(IM,LLL.IMMM(JH)) IL=MIN(IL,LLL.IMMM(JH)) 3540 CONTINUE LLL.IML=IL ll.lcara(1,iH)=IL LLL.IMM=LL.ipno(IM) if (immt(ih).ne.0) then immt(ih)=min(immt(ih),ll.ipno(IM)) else immt(ih)=ll.ipno(IM) endif 3520 CONTINUE C 3530 CONTINUE LLL=LL.ILIGN(IL1) IL22=LLL.IPREL C C **** BOUCLE *5* TRAVAILLE SUR LE NOEUD I QUI EST EN LECTURE C C lig1=MM.ilign(IMINM) C lig2=LL.ilign(IMINL) ipos=0 iper=IMINM ider=IMINM-1 iderac=IMINM-1 IMINA=MIN(IMINM,IMINL) IMIN = IMINA DO 5 I=IMINA,IL2 LIG1=MM.ILIGN(I) LIG2=LL.ILIGN(I) IF(I.LT.IL1) GO TO 7 C C ******* LE NOEUD I EST EN MEMOIRE IL EST TRIANGULE JUSQU'A C ******* IPREL IL FAUT CONTINUER TOUTE LES LIGNES PUIS CALCULER C ******* LE TERME DIAGONAL C C on s'occupe d'abord de la partie superieur LIGN=LIG1 NAA= IMMM(/1) DO 156 KHG=1,NAA LIGN=LIG1 II=IPREL-1+KHG IMMM(KHG)=0 NN1=IPPVV(KHG+1) NNM1=IPPVV(KHG) NNM1S=NNM1 N=NN1-NNM1 DIAG(II)=VAL(NN1) diagref=diag(ii) IF(N.EQ.1) GO TO 8 NMI=N-II IDEP=MAX(IL11,2-NMI) KIDEP=IDEP+NMI KI1=N-1 KQ=-NMI C WRITE(IOIMP,*)'Avant CHOLI1, Imasq(/1)=',Imasq(/1) * WRITE(IOIMP,*)'Avant CHOLI1-1 ',val(nn1) VAL(NN1)=VAL(NN1)+ # CHOLI1(LL.ILIGN,LIG2,LIG1.VAL(1+IPPVV(KHG)),DIAG(1-NMI), # LL.IPNO(1-NMI),LIG1.IPPVV(1),KHG,LIG1.IVPO(1),KIDEP,KI1, # KQ,LIG1.imasq(1),1+IPPVV(KHG),PREC,1,nbop(1)) lig1.imasq(masqa(nn1))=1 lig1.imasq(masqa(n))=1 8 CONTINUE LIGN=LIG2 II=IPREL-1+KHG IMMM(KHG)=0 NN2=IPPVV(KHG+1) NNM1=IPPVV(KHG) N=NN2-NNM1 IF(N.EQ.1) GO TO 88 NMI=N-II IDEP=MAX(IL22,2-NMI) KIDEP=IDEP+NMI KI1=N-1 KQ=-NMI * WRITE(IOIMP,*)'Avant CHOLI1-2 ',val(nn2) VAL(NN2)=VAL(NN2)+ # CHOLI1(MM.ILIGN,LIG1,VAL(1+IPPVV(KHG)),DIAG(1-NMI), # MM.IPNO(1-NMI),IPPVV(1),KHG,IVPO(1),KIDEP,KI1, # KQ,LIG2.imasq(1),1+IPPVV(KHG),PREC,2,nbop(1)) lig2.IMASQ(masqa(nn2))=1 lig2.IMASQ(masqa(n))=1 88 CONTINUE LIGN=LIG1 diagref=max(abs(diag(ii)),diagmin) diagcmp=diagref*5d-12 IF(LL.ITTR(II).EQ.0.AND. & ABS(LIG2.VAL(NN2)).GT.diagcmp) GO TO 12 IF(LL.ITTR(II).NE.0.AND. & ABS(LIG2.VAL(NN2)).GT.diagcmp) GO TO 12 C il faut mettre une valeur plus grande sur les LX car on a un probleme de conditionnement C sur le calcul des reactions en cas de 2 relations presque identique C C **** ON VIENT DE DETECTER UN MODE D'ENSEMBLE C **** ON AJOUTE A LA STRUCTURE UN RESSORT EGAL A CELUI QUI EXISTAIT C **** AU PREALABLE SUR CETTE INCONNUE. C * write (6,*) ' ldmt3 mode d ensemble ittr ligne ', * > ittr(ii),ii,diag(ii),val(nn2),lig2.val(nn2),diagref,diagcmp C on garde le signe car il fau un moins sur les ML vmaxi=diagref do ipv=1+ippvv(khg),nn2 vmaxi=max(vmaxi,abs(lig2.val(ipv))) enddo if(LL.ittr(ii).NE.0) then LIG2.VAL(NN2)=LIG2.VAL(NN2)-4.D0*diagref NENSLX=NENSLX+1 else LIG2.VAL(NN2)=vmaxi endif NENS=NENS+1 LIG2.IMMM(KHG)=NENS LIG1.IMMM(KHG)=NENS 12 CONTINUE DIAG(II)=LIG2.VAL(NN2) IF(DIAG(II).NE.0.D0) GO TO 41 KQ1=1+NNM1S KQN=N+NNM1S DO 16 LFG=KQ1,KQN IF(LIG1.VAL(LFG).NE.0.D0) GO TO 17 16 CONTINUE KQ1=1+NNM1 KQN=N+NNM1 DO 160 LFG=KQ1,KQN IF(LIG2.VAL(LFG).NE.0.D0) GO TO 170 160 CONTINUE DIAG(II)=1.D0 if (LL.ittr(ii).ne.0) diag(ii)=-1 LIG2.VAL(NN2)=DIAG(II) GO TO 41 17 CONTINUE C write (6,*) ' ldmt3 apres 17 ',val(lfg) diag(ii)=LIG1.VAL(LFG) goto 171 170 CONTINUE diag(ii)=LIG2.VAL(LFG) 171 continue if (LL.ittr(ii).ne.0) diag(ii)=-abs(diag(ii)) *** LIG2.val(nn2)=diag(ii) GOTO 41 C C **** ENVOI ERREUR MATRICE SINGUIERE C C ITYP=49 INTERR(1)=I CALL ERREUR(49) if (ithrd.eq.1) then call threadis call oooprl(0) endif call ooomru(0) RETURN C C **** ON COMPTE LE NOMBRE DE TERMES DIAGONAUX NEGATIFS C ET LE NOMBRE DE MULTIPLICATEUR DE LAGRANGE C 41 IF(DIAG(II).LT.0.D0) INEG=INEG+1 IF(LL.ITTR(II).NE.0) NBLAG=NBLAG+1 LIG1.VAL(NN1)=DIAG(ii) condmin=min(condmin,abs(diag(ii))) condmax=max(condmax,abs(diag(ii))) diag(ii)=1.d0/diag(ii) 156 CONTINUE C C RECOMPACTAGE DE LIGN (DEJA ENTIEREMENT TRAITEE) C d'abord la triangulaire superieure C NA=LIG1.IMMM(/1) NBPAR=NA+1 if (na.gt.0) > CALL COMPAC(LIG1.VAL(1),NBPAR,KIVPO(1),KIVLO(1), # NVALL,LIG1.IPPVV(1),IZROSF,NA,PREC,lig1.imasq(1), # LIG1.IPREL,LIG1.IDERL) C on recree lig1 car la compacter en place emiette la memoire lmasq=0 lig3=lig1 segini /err=1431/ lig3 1431 continue * deplacement fait ici maintenant, avec unrolling do 300 nbp=1,nbpar-1 kdif =kivpo(nbp)-kivlo(nbp) do iv=kivlo(nbp),kivlo(nbp+1)-4,4 lig3.val(iv)=lig1.val(iv+kdif ) lig3.val(iv+1)=lig1.val(iv+1+kdif ) lig3.val(iv+2)=lig1.val(iv+2+kdif ) lig3.val(iv+3)=lig1.val(iv+3+kdif ) enddo do iv1=iv,kivlo(nbp+1)-1 lig3.val(iv1)=lig1.val(iv1+kdif ) enddo 300 continue ** do it=1,nvall ** lig3.val(it)=lig1.val(it) ** enddo do it=1,na lig3.immm(it)=lig1.immm(it) lig3.ippvv(it)=lig1.ippvv(it) enddo lig3.ippvv(na+1)=lig1.ippvv(na+1) lig3.iml=lig1.iml lig3.iprel=lig1.iprel lig3.iderl=lig1.iderl mm.lcara(1,i)=lig3.iml mm.lcara(2,i)=lig3.iprel mm.lcara(3,i)=lig3.iderl if (lig3.ne.lig1) then segsup lig1 else segadj lig3 endif lig1=lig3 mm.ilign(i)=lig3 NVSTOR=NVSTOR+NVALL nvstrm=max(nvstrm,nvall) DO 143 LHG=1,NBPAR LIG1.IVPO(2*LHG-1)=KIVPO(LHG) LIG1.IVPO(2*LHG) =KIVLO(LHG) 143 CONTINUE C C RECOMPACTAGE DE LIGN (DEJA ENTIEREMENT TRAITEE) C puis la triangulaire inférieure C NA=LIG2.IMMM(/1) NBPAR=NA+1 if (na.gt.0) > CALL COMPAC(LIG2.VAL(1),NBPAR,KIVPO(1),KIVLO(1), # NVILL,LIG2.IPPVV(1),IZROSF,NA,PREC,lig2.imasq(1), # LIG2.IPREL,LIG2.IDERL) NVALL=NVILL C on recree lig2 car la compacter en place emiette la memoire C WRITE(IOIMP,*) 'Valeur de LIG2', LIG2 lig3=lig2 lmasq=0 segini /err=1432/ lig3 1432 continue * deplacement fait ici maintenant, avec unrolling do 301 nbp=1,nbpar-1 kdif =kivpo(nbp)-kivlo(nbp) do iv=kivlo(nbp),kivlo(nbp+1)-4,4 lig3.val(iv)=lig2.val(iv+kdif ) lig3.val(iv+1)=lig2.val(iv+1+kdif ) lig3.val(iv+2)=lig2.val(iv+2+kdif ) lig3.val(iv+3)=lig2.val(iv+3+kdif ) enddo do iv1=iv,kivlo(nbp+1)-1 lig3.val(iv1)=lig2.val(iv1+kdif ) enddo 301 continue ** do it=1,nvall ** lig3.val(it)=lig2.val(it) ** enddo do it=1,na lig3.immm(it)=lig2.immm(it) lig3.ippvv(it)=lig2.ippvv(it) enddo lig3.ippvv(na+1)=lig2.ippvv(na+1) lig3.iml=lig2.iml lig3.iprel=lig2.iprel lig3.iderl=lig2.iderl ll.lcara(1,i)=lig3.iml ll.lcara(2,i)=lig3.iprel ll.lcara(3,i)=lig3.iderl if (lig3.ne.lig2) then segsup lig2 else segadj lig3 endif lig2=lig3 ll.ilign(i)=lig2 NVSTIR=NVSTIR+NVILL nvstrm=max(nvstrm,nvIll*inpdo) DO 1430 LHG=1,NBPAR LIG2.IVPO(2*LHG-1)=KIVPO(LHG) LIG2.IVPO(2*LHG) =KIVLO(LHG) 1430 CONTINUE IF (I.GT.1) THEN LIG1=MM.ILIGN(I-1) LIG2=LL.ILIGN(I-1) if (lsgdes) SEGDES LIG1,LIG2 IDERAC=MIN(IDERAC,I-2) ENDIF C C **** ON TRIANGULARISE LES AUTRES LIGNES C IL1=IL1+1 IF (IL1.GT.IL2) GOTO 5 LIG1=MM.ILIGN(I) LIGN=MM.ILIGN(IL1) IL11=IPREL LIG2=LL.ILIGN(I) LIGN=LL.ILIGN(IL1) IL22=IPREL GOTO 7 C 72 CONTINUE 71 CONTINUE * passage en superlent if (ider.lt.il1-1.and..not.ngmpet) then ngmpet=.true. endif if (iper.gt.ider) then call erreur(48) call ooodmp(0) if (ithrd.eq.1) then call threadis call oooprl(0) endif call ooomru(0) return endif *** IF (I.LT.IL1-10) THEN C SOIT PARCE QU'ON A FINI, SOIT PARCE QU'ON MANQUE DE MEMOIRE C IL FAUT EXECUTER LES LIGNES ACTIVEES PUIS LES DESACTIVER C LANCER LES CHOLE3 ET ATTENDRE QU'ILS SOIENT FINIS IF (IPOS.NE.0) THEN C WRITE (6,*) ' LANCEMENT THREAD ',IPER,IDER,IL1,IL2 IF (IPER.GT.IDER) THEN WRITE (6,*) ' ERREUR INTERNE LDMT3 ' CALL ERREUR(5) ENDIF C WRITE (6,*) ' NBTHR-2 ',NBTHR NBTHR=MIN(NBTHR,IL2-IL1+1) ** WRITE (6,*) ' NBTHR-3 ',NBTHR MILIGN=MM LILIGN=LL C Write(6,*) 'ldmt3.eso On passe LL dans LILIGN : ', LILIGN * blocage pour rester dans le cache secondaire ipers=iper iders=ider ipas=1500 if(nbthr.eq.1) ipas=igrand 401 continue ider=min(iders,iper+ipas-1) DO ITH=1,NBTHR-1 CALL THREADID(ITH,CHOLE3I) ENDDO CALL CHOLE3I(NBTHR) DO ITH=1,NBTHR-1 CALL THREADIF(ITH) ENDDO iper=iper+ipas ipas=ipas/2 ipas=max(ipas,750) if(iper.le.iders) goto 401 MILIGN=LL LILIGN=MM C Write(6,*) 'ldmt3.eso On passe MM dans LILIGN : ', LILIGN * blocage pour rester dans le cache secondaire ipas=1500 if(nbthr.eq.1) ipas=igrand iper=ipers 402 continue ider=min(iders,iper+ipas-1) DO ITH=1,NBTHR-1 CALL THREADID(ITH,CHOLE3I) ENDDO CALL CHOLE3I(NBTHR) DO ITH=1,NBTHR-1 CALL THREADIF(ITH) ENDDO iper=iper+ipas ipas=ipas/2 ipas=max(ipas,750) if(iper.le.iders) goto 402 iper=ipers ider=iders ENDIF * test ctrlC if (ierr.ne.0) goto 9999 IPOSM=MAX(IPOSM,IPOS) IPOS=0 IDERF=IDER-1 IDERF=IDER IF (IDER.NE.IL1-1) IDERF=IDER if(lsgdes) then DO IL=IDERF,IPER,-1 LIGN=MM.ILIGN(IL) SEGDES LIGN LIGN=LL.ILIGN(IL) SEGDES LIGN C WRITE (6,*) ' DESACTIVATION LIGNE & COLONNE ',IL ENDDO endif IDERAC=MIN(IDERAC,IPER-1) IPER=IDER+1 C WRITE (6,*) ' IPER IDER IL1 ',IPER,IDER,IL1 IF (IPER.NE.IL1) GOTO 7 GOTO 5 7 CONTINUE if(lsgdes) then SEGACT/ERR=71/LIG1 SEGACT/ERR=71/LIG2 endif IPOS=IPOS+1 IDER=I IF (I.GT.IDERAC) IDERAC=I IF (I.EQ.IL1-1) GOTO 71 5 CONTINUE if(lsgdes) then DO I=min(IL1,IL2),max(il1,il2) LLL=LL.ILIGN(I) if (lll.ne.0) segdes lll MMM=MM.ILIGN(I) if (mmm.ne.0) segdes mmm C Write(6,*)' SEGDES de LLL, MMM : ',LLL,MMM enddo endif nbopt=0 do ith=1,nbthro nbopt=nbopt+nbop(ith) nbop(ith)=0 enddo nbopin=nbopt nbopit=nbopit+nbopin call timespv(ittime,oothrd) kcour=(ittime(1)+ittime(2))/10 kdiff=kcour-kcourp C* write (6,*) ' nb operation temps ',nbopin,kdiff if (kdiff.ge.1) then perf=real(nbopin)/kdiff C* if (nbchan.ne.0) perfp=perf if (ngdyn) then if (perf.lt.perfp*0.90 .and.nbchan.ne.1 ) then nbchan=1 perfp=perf elseif (nbchan.eq.0) then nbchan=-1 perfp=max(perf,perfp) else nbchan=0 endif endif C* nbchan=0 endif kcourp=kcour iderac=min(iderac,il1-1) if(ireser.ne.0) segsup ireser IF(IL2.LT.INO) GO TO 1 C ON MET A JOUR LE NOMBRE DE TERMES DIAGONAUX NEGATIF C ON ENLEVE LE NOMBRE DE MULTIPLICATEUR DE LAGRANGE C INEG=INEG-NBLAG C on ne compte pas 2 fois les multiplicateurs qui vont etre C elimines lors de la resolution car mode d'ensemble INEG=INEG-(NBLAG-NENSLX) if (iimpi.ne.0.and.NENSLX.gt.0) WRITE(IOIMP,4820) NENSLX 4820 FORMAT(I12,' MODES D ENSEMBLE PORTANT SUR DES MULTIPLICATEURS', 1' DE LAGRANGE DETECTES') IF (IIMPI.EQ.1) WRITE(IOIMP,4821) NVSTOC+NVSTIC 4821 FORMAT( ' NOMBRE DE VALEURS DANS LE PROFIL',I12) IF (IIMPI.EQ.1) WRITE(IOIMP,4822) NVSTOR+NVSTIR 4822 FORMAT( ' NOMBRE DE VALEURS STOCKEES DANS LE PROFIL',I12) IF (IIMPI.EQ.1) WRITE(IOIMP,4825) Nbopit/1000000 4825 FORMAT( ' NOMBRE DE GIGA OPERATIONS FMA',I40) IF (IIMPI.EQ.1) WRITE(IOIMP,4823) NVaor+NVaori 4823 FORMAT( ' NOMBRE DE VALEURS initiales',I12) INTERR(1)=NVSTOR+NVSTIR reaerr(1)=nvstor/inc**(4./3) reaerr(2)=2*nbopit/1D6/max(1,(kcour-kcouri)) reaerr(3)=condmax/condmin IF (IPASV.EQ.0.or.reaerr(3).gt.1.D30) CALL ERREUR(-278) IPASV=1 call ooomru(0) if(lsgdes) then do ipv=1,ino lign=mm.ilign(ipv) segdes lign lign=ll.ilign(ipv) segdes lign enddo endif SEGDES,MINCPO SEGDES,MIMIK SEGDES,MMATRI SEGDES,LL,MM SEGDES,MDIAG MMATRX=MMATRI SEGSUP KIVPO,KIVLO segsup immt 9999 continue if (ithrd.eq.1) then call threadis call oooprl(0) endif RETURN END