1 : C RESOU1 SOURCE CHAT 09/10/09 21:22:52 6519 2 : SUBROUTINE RESOU1(KRIGI,IDAMEM,NOID,NOEN,prec) 3 : C 4 : C **** SUBROUTINE QUI EXECUTE L OPERATION RESOU 5 : C **** APPELEE PAR RESOU OU PAR SUPRI 6 : C 7 : IMPLICIT INTEGER(I-N) 8 : IMPLICIT REAL*8 (A-H,O-Z) 9 : INTEGER OOOVAL 10 : SEGMENT IDEMEM(0) 11 : -INC SMRIGID 12 : -INC SMVECTD 13 : -INC CCOPTIO 14 : -INC SMMATRI 15 : C 16 : MRIGID=KRIGI 17 : SEGACT MRIGID 18 : ICHOLX=ICHOLE 19 : SEGDES MRIGID 20 : IF(ICHOLX.NE.0) then 21 : MMATRI=ICHOLX 22 : SEGACT MMATRI 23 : IF (PRCHLV.lt.PREC*1.001.and.PRCHLV.gt.PREC*0.999) GO TO 1 24 : write (6,*) ' attention changement de precision ' 25 : MILIGN=IILIGN 26 : segact milign 27 : DO 20 I=1,ILIGN(/1) 28 : LIGN=ILIGN(I) 29 : SEGSUP LIGN 30 : 20 CONTINUE 31 : MDIAG=IDIAG 32 : SEGSUP MDIAG 33 : MDNOR=IDNORM 34 : SEGSUP MDNOR 35 : SEGSUP MMATRI 36 : ICHOLX=0 37 : ENDIF 37 : CALL TRIANG(KRIGI,prec ) 38 : IF(IERR.NE.0) GO TO 5000 39 : MRIGID=KRIGI 40 : SEGACT MRIGID 41 : ICHOLX=ICHOLE 42 : SEGDES MRIGID 43 : C 44 : C **** SUBROUTINE CHV2 : TRANSFORME LE CHPOIN ISECO EN VECTEUR 45 : C 46 : 1 CONTINUE 47 : IDEMEM=IDAMEM 48 : SEGACT IDEMEM*MOD 49 : NNTOT=IDEMEM(/1) 50 : MMATRI=ICHOLX 51 : SEGACT MMATRI 52 : MILIGN=IILIGN 53 : SEGACT,MILIGN 54 : INK=IPNO(/1) 55 : SEGDES MILIGN,MMATRI 55 : CALL INTPDO(LENB) 56 : NNPA= MAX(1,((OOOVAL(1,1)-NGMAXY)/(2*LENB))/INK+1) 57 : C 58 : C ON TRAVAILLE AVEC AUTANT DE VECTEUR SIMULTANEE QU'IL EN RENTRE DANS 59 : C LA MOITIE DE LA MEMOIRE CENTRALE 60 : C 61 : NN=NNPA 62 : DO 201 KGEN = 1,NNTOT,NNPA 63 : IF(KGEN+NNPA-1.GT.NNTOT) NN= NNTOT-KGEN+1 64 : KGEN1=KGEN-1 65 : DO 2 K=1,NN 66 : ISECO=IDEMEM(K+KGEN1) 66 : CALL CHV2(ICHOLX,ISECO,MVECTX,NOID) 67 : IF(IERR.NE.0) GO TO 5000 68 : IDEMEM(K+KGEN1)=MVECTX 69 : 2 CONTINUE 70 : IF(NN.NE.1) THEN 71 : INC = INK * NN 72 : SEGINI MVECTD 73 : DO 3 LL=1,NN 74 : LD=INK*(LL-1) 75 : MVECT1=IDEMEM(LL+KGEN1) 76 : SEGACT MVECT1 77 : DO 4 L=1,INK 78 : 4 VECTBB(L+LD)=MVECT1.VECTBB(L) 79 : SEGSUP MVECT1 80 : 3 CONTINUE 81 : MVECTX=MVECTD 82 : SEGDES MVECTD 83 : ENDIF 84 : C 85 : C **** SUBROUTINE MONDES : 86 : C 87 : IF(IIMPI.EQ.1) THEN 88 : WRITE(IOIMP,499) 89 : 499 FORMAT(' TEMPS SUIVANT AVANT APPEL MONDES') 89 : CALL GIBTEM(XKT) 90 : INTERR(1)=XKT 90 : CALL ERREUR(-259) 91 : ENDIF 91 : CALL MONDES(ICHOLX,MVECTX,NOEN) 92 : IF(IIMPI.EQ.1) THEN 93 : WRITE(IOIMP,498) 94 : 498 FORMAT(' TEMPS SUIVANT APRES APPEL MONDES') 94 : CALL GIBTEM(XKT) 95 : INTERR(1)=XKT 95 : CALL ERREUR(-259) 96 : ENDIF 97 : IF(IERR.NE.0) GO TO 5000 98 : C 99 : C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT 100 : C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE 101 : C 102 : MVECTA=MVECTX 103 : DO 5 K=1,NN 104 : IF(NN.EQ.1) GO TO 10 105 : IF(K.EQ.1) THEN 106 : INC=INK 107 : MVECT1=MVECTX 108 : SEGACT MVECT1 109 : SEGINI MVECTD 110 : ENDIF 111 : SEGACT MVECTD*MOD 112 : LD=(K-1)*INK 113 : DO 6 L=1,INK 114 : VECTBB(L)=MVECT1.VECTBB(L+LD) 115 : 6 CONTINUE 116 : MVECTA=MVECTD 117 : SEGDES MVECTD 118 : IF(K.EQ.NN) SEGSUP MVECT1 119 : 10 CONTINUE 119 : CALL VCH1(ICHOLX,MVECTA,ISOLU,KRIGI) 120 : IF(IERR.NE.0) RETURN 121 : C 122 : IDEMEM(K+KGEN1)=ISOLU 123 : 5 CONTINUE 124 : MVECTD=MVECTA 125 : SEGSUP MVECTD 126 : 201 CONTINUE 127 : IDAMEM = IDEMEM 128 : SEGDES IDEMEM 129 : C 130 : 5000 CONTINUE 131 : RETURN 132 : END 133 : 134 : 135 : 136 : 137 : 138 : 139 : 140 : 141 : 142 : 143 : 144 :
© Cast3M 2003 - All rights reserved.
Disclaimer