1 : C OPTNUM SOURCE PV 10/09/28 21:15:00 6768 2 : SUBROUTINE OPTNUM(MELEME,MEMJT1,memjt2,JMEM,JNT,NEWJT,JOINT, 3 : > IDIFF,IPOME,ICPR,NODES,NOOPTI) 4 : * 5 : * renumérotation des noeuds en vue de la résolution 6 : * par la méthode de Cuthill Mac Kee inversée 7 : * 8 : * 9 : IMPLICIT INTEGER(I-N) 10 : -INC SMELEME 11 : -INC CCOPTIO 12 : SEGMENT MEMJT1(0) 13 : SEGMENT MEMJT2(0) 14 : SEGMENT IPOME(0) 15 : SEGMENT JNT (0) 16 : SEGMENT JMEM (0) 17 : SEGMENT NEWJT(0) 18 : SEGMENT JOINT(0) 19 : SEGMENT ICPR (0) 20 : C SEGMENT OU STOCKE LES ELEMENTS DEJA ESSAYES 21 : SEGMENT IDJFC(IDJFCL) 22 : SEGMENT IDJF(IDJFL) 23 : C SEGMENT OU STOCKER LES POINTS DE DEPARTS DEJA ESSAYES 24 : SEGMENT NPES(NODES) 25 : CHARACTER*4 MVAL(1) 26 : INTEGER IPASG 27 : SAVE IPASG 28 : DATA IPASG/0/ 29 : DATA MVAL/'NOOP'/ 30 : lasur0=0 31 : cout0=0.d0 32 : NOOPTI=0 33 : IPT1=MELEME 33 : CALL LIRMOT(MVAL,1,IRET,0) 34 : IF (IRET.EQ.0) GOTO 2 35 : NOOPTI=1 36 : DO 4 J=1,NODES 37 : JNT(J)=J 38 : 4 CONTINUE 39 : RETURN 40 : 2 CONTINUE 41 : SEGINI NPES 42 : DO 5 I=1,NODES 43 : NPES(I)=0 44 : 5 CONTINUE 45 : IDJFCL=MAX(1,LISOUS(/1)) 46 : SEGINI IDJFC 47 : IPT1=MELEME 48 : DO 6 ISOUS=1,IDJFCL 49 : IF (LISOUS(/1).NE.0) IPT1=LISOUS(ISOUS) 50 : IDJFL=IPT1.NUM(/2) 51 : SEGINI IDJF 52 : IDJFC(ISOUS)=IDJF 53 : 6 CONTINUE 54 : MINMAX=500000 55 : ICON=1 56 : ITER=1 57 : IBOUT=1 58 : IK=1 59 : NK5=1 60 : 1 CONTINUE 61 : NPES(IK)=1 62 : DO 230 IO=1,MAX(1,LISOUS(/1)) 63 : IF(LISOUS(/1).NE.0) IPT1=LISOUS(IO) 64 : IF(IPT1.ITYPEL.NE.22) GO TO 230 65 : DO 240 LA=1,IPT1.NUM(/2) 66 : NPES(ICPR(IPT1.NUM(1,LA)))=1 67 : NPES(ICPR(IPT1.NUM(2,LA)))=1 68 : 240 CONTINUE 69 : 230 CONTINUE 70 : DO 20 J=1,NODES 71 : JOINT(J)=0 72 : 20 NEWJT(J)=0 73 : LASURT=0 74 : MUX=0 75 : I=1 76 : NEWJT(1)=IK 77 : JOINT(IK)=1 78 : K=1 79 : 30 IND=NEWJT(I) 80 : IND1=IND 81 : K4=JMEM(IND) 82 : JSUB=IPOME(NEWJT(I)) 83 : * tentative tc 84 : DO 40 JJ=k4,1,-1 85 : IND=JSUB+JJ 86 : IAIA= memjt2(ind) 87 : K6=memjt1(ind) 88 : IDJF=IDJFC(MAX(1,IAIA)) 89 : IF (IDJF(K6).EQ.1) GOTO 40 90 : IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA) 91 : IPOSL2=0 92 : DO 85 L=1,IPT1.NUM(/1) 93 : K5=ICPR(IPT1.NUM(L,K6)) 94 : IF (JOINT(K5).GT.0) GO TO 85 95 : if (npes(k5).eq.0) nk5=k5 96 : K=K+1 97 : NEWJT(K)=K5 98 : JOINT(K5)=K 99 : NDIFF=ABS(I-K) 100 : MUX=MAX(MUX,NDIFF) 101 : IF(IPT1.ITYPEL.EQ.22.AND.IPT1.NUM(/1).NE.0) GO TO 86 102 : GOTO 85 103 : 86 CONTINUE 104 : * on insere le multiplicateur 1 avant i (deja atteint) 105 : * on insere le second apres le noeud le plus haut de l'element (type 22 106 : * on mettra celui-ci apres tous les autres 107 : IF (L.EQ.1) THEN 108 : DO 87 M=K,I+1,-1 109 : NEWJT(M)=NEWJT(M-1) 110 : JOINT(NEWJT(M))=M 111 : 87 CONTINUE 112 : NEWJT(I)=K5 113 : JOINT(K5)=I 114 : I=I+1 115 : ELSEIF (L.EQ.2) THEN 116 : IPOSL2=K 117 : ENDIF 118 : 85 CONTINUE 119 : IDJF(K6)=1 120 : 121 : IF (IPT1.ITYPEL.EQ.22.AND.IPOSL2.NE.0) THEN 122 : * on s'occupe maintenant du 2eme multiplicateur de lagrange 123 : IHAUT=0 124 : DO 89 L=3,IPT1.NUM(/1) 125 : K3=ICPR(IPT1.NUM(L,K6)) 126 : IHAUT=MAX(IHAUT,JOINT(K3)) 127 : 89 CONTINUE 128 : NEWSAU=NEWJT(IPOSL2) 129 : IF(IHAUT+1.EQ.IPOSL2) GO TO 40 130 : IF (IHAUT.LT.IPOSL2) THEN 131 : DO 88 M=IPOSL2,IHAUT+2,-1 132 : NEWJT(M)=NEWJT(M-1) 133 : JOINT(NEWJT(M))=M 134 : 88 CONTINUE 135 : NEWJT(IHAUT+1)=NEWSAU 136 : JOINT(NEWSAU)=IHAUT+1 137 : ELSE 138 : DO 84 M=IPOSL2,IHAUT-1 139 : NEWJT(M)=NEWJT(M+1) 140 : JOINT(NEWJT(M))=M 141 : 84 CONTINUE 142 : NEWJT(IHAUT)=NEWSAU 143 : JOINT(NEWSAU)=IHAUT 144 : ENDIF 145 : ENDIF 146 : 40 CONTINUE 147 : IF(K.EQ.NODES) GO TO 50 148 : I=I+1 149 : IF (I.NE.K+1) GO TO 30 150 : K=K+1 151 : DO 23 L=1,NODES 152 : IF (JOINT(L).EQ.0) GO TO 24 153 : 23 CONTINUE 153 : CALL ERREUR(9) 154 : 24 CONTINUE 155 : NEWJT(K)=L 156 : JOINT(L)=K 157 : IBOUT=IBOUT+1 158 : GO TO 30 159 : 50 CONTINUE 160 : * 60 CONTINUE 161 : II=IK 162 : INTERR(1)=IBOUT 163 : IF(ITER.EQ.1.AND.IBOUT.NE.1.AND.IPASG.EQ.0) THEN 163 : IF(LOCERR(1:4).EQ.'RESO') CALL ERREUR(754) 164 : IPASG = 1 165 : ENDIF 166 : LASURT=0 167 : LASURF=0 168 : DO 46 IB=1,NODES 169 : LONG=IB 170 : LANG=IB 171 : IC=NEWJT(IB) 172 : K4=JMEM(IC) 173 : JSUB=IPOME(IC) 174 : DO 43 JJB=1,K4 175 : IND=JSUB+JJB 176 : IAIA= memjt2(ind) 177 : IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA) 178 : K6=memjt1(ind) 179 : DO 44 IKL=1,IPT1.NUM(/1) 180 : JKL=JOINT(ICPR(IPT1.NUM(IKL,K6))) 181 : LONG=MAX(LONG,JKL) 182 : LANG=MIN(LANG,JKL) 183 : 44 CONTINUE 184 : 43 CONTINUE 185 : LASURT=LASURT+LONG-IB 186 : LASURF=LASURF+IB-LANG 187 : 46 CONTINUE 188 : ** IF (MINMAX.LE.MUX) GOTO 60 189 : ** if (lasur0.ne.0.and.lasurt.gt.lasur0) goto 60 190 : cout=5.d0*log(real(mux))+log(real(lasurt))+log(real(lasurf)) 191 : if (cout0.ne.0.d0.and.cout.ge.cout0) goto 60 192 : cout0=cout 193 : 194 : MINMAX=MIN(MINMAX,MUX) 195 : lasur0=lasurt 196 : IF(IIMPI.EQ.3) 197 : 1WRITE (IOIMP,62) ITER,IK,MUX,LASURF,LASURT 198 : 62 FORMAT(' ITERATION:',I3,' DEPART:',I8,' BANDE:',I6,' SURFACE: ', 199 : #I13,' SURF INV:',I13) 200 : DO 55 J=1,NODES 201 : 55 JNT(J)=JOINT(J) 202 : ICON=0 203 : NVOIS=0 204 : 60 CONTINUE 205 : IK=NK5 206 : DO 95 IO=1,IDJFC(/1) 207 : IDJF=IDJFC(IO) 208 : DO 97 LA=1,IDJF(/1) 209 : 97 IDJF(LA)=0 210 : 95 CONTINUE 211 : ICON=ICON+1 212 : ITER=ITER+1 213 : IF (ICON.LE.3.AND.NPES(IK).EQ.0) GOTO 1 214 : IF (NVOIS.GT.0) GO TO 101 215 : LH=0 216 : nvois=0 217 : 101 continue 218 : do i=1,nodes 219 : newjt(jnt(i))=i 220 : enddo 221 : 102 continue 222 : lh=lh+1 223 : if (lh.gt.nodes) goto 71 224 : if (nvois.gt.64) goto 71 225 : ik=newjt(lh) 226 : if (nvois.ge.128) ik=newjt(nodes+129-lh) 227 : if (npes(ik).eq.1) goto 102 228 : nvois=nvois+1 229 : goto 1 230 : 71 CONTINUE 231 : IDIFF=MINMAX 232 : DO 105 J=1,IDJFC(/1) 233 : IDJF=IDJFC(J) 234 : SEGSUP IDJF 235 : 105 CONTINUE 236 : SEGSUP IDJFC 237 : SEGSUP NPES 238 : RETURN 239 : END 240 :
© Cast3M 2003 - All rights reserved.
Disclaimer