1 : C RLEVB1 SOURCE CHAT 05/01/13 03:01:51 5004 2 : SUBROUTINE RLEVB1(MELSOM,MELCEN,MLELSC,MLELSB,MLESBC,MLRDIS) 3 : C 4 : C 5 : C**** Variables de COOPTIO 6 : C 7 : C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR 8 : C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ 9 : C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES 10 : C & ,IECHO, IIMPI, IOSPI 11 : C & ,IDIM 12 : CC & ,MCOORD 13 : C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE 14 : C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU 15 : C & ,NORINC,NORVAL,NORIND,NORVAD 16 : C & ,NUCROU, IPSAUV 17 : C 18 : IMPLICIT INTEGER(I-N) 19 : INTEGER NCEN,I1,NMAXCE,ICEL,NMAXS,LAST,IPLSB1,IPLSB2 20 : & ,NGS,NLS,NSVOI,IPLSC1,IPLSC2,NGS1,ICEL1,NCVOI,NGC,NLC 21 : & ,I2,IPOS,NLS1,NTOTCV,NGS2,IPCOOR,I3,NCMIS 22 : REAL*8 XS,YS,ZS,DXC,DYC,DZC, DIST2, DIST21 23 : C 24 : -INC SMELEME 25 : INTEGER JG 26 : -INC SMLENTI 27 : -INC SMLREEL 28 : -INC CCOPTIO 29 : -INC SMCOORD 30 : C 31 : INTEGER NBL, NBTPOI 32 : SEGMENT MLELEM 33 : INTEGER INDEX(NBL+1) 34 : INTEGER LESPOI(NBTPOI) 35 : ENDSEGMENT 36 : POINTEUR MLELSC.MLELEM, MLELSB.MLELEM, MLESBC.MLELEM 37 : C 38 : POINTEUR MELSOM.MELEME, MELCEN.MELEME 39 : C 40 : POINTEUR MLESOM.MLENTI, MLECEN.MLENTI 41 : & ,MLECVO.MLENTI 42 : POINTEUR MLRDIS.MLREEL 43 : C 44 : C**** Le MELEME SOMMET 45 : C 45 : CALL KRIPAD(MELSOM,MLESOM) 46 : C 47 : C MLESOM: numerotation globale -> locale 48 : C 49 : C**** En KRIPAD 50 : C SEGACT MELSOM 51 : C SEGINI MLESOM 52 : C 53 : C**** Le MELEME CENTRE 54 : C 54 : CALL KRIPAD(MELCEN,MLECEN) 55 : C 56 : C MLECEN: numerotation globale -> locale 57 : C 58 : C**** En KRIPAD 59 : C SEGACT MELCEN 60 : C SEGINI MLECEN 61 : C 62 : NCEN=MELCEN.NUM(/2) 63 : C 64 : NMAXCE=0 65 : SEGACT MLELSC 66 : NBL=MLELSC.INDEX(/1)-1 67 : DO I1 = 1, NBL, 1 68 : ICEL=MLELSC.INDEX(I1+1)-MLELSC.INDEX(I1)-1 69 : NMAXCE=MAX(NMAXCE,ICEL) 70 : ENDDO 71 : C 72 : SEGACT MLELSB 73 : NMAXS=0 74 : NBL=MLELSB.INDEX(/1)-1 75 : DO I1 = 1, NBL, 1 76 : ICEL=MLELSB.INDEX(I1+1)-MLELSB.INDEX(I1)-1 77 : NMAXS=MAX(NMAXS,ICEL) 78 : ENDDO 79 : C 80 : C**** NBL de MLELSB = NBL de MLESBC 81 : C Surestimation des noeuds en MLESBC 82 : C 83 : NBTPOI=(NBL+1)*(NMAXCE*NMAXS) 84 : SEGINI MLESBC 85 : JG=NBTPOI 86 : SEGINI MLRDIS 87 : C 88 : C**** MLRDIS = dedans la structure MLESBC, distance (au carre) 89 : C premier noeud et ses voisins 90 : C 91 : C 92 : C**** MLECVO + LAST = liste chaînée des centres voisins 93 : C d'un sommet au bord 94 : JG=NCEN 95 : SEGINI MLECVO 96 : LAST=-1 97 : C 98 : C**** Soit NGS un sommet sur le bord. 99 : C Je dois créer la liste des centres voisins 100 : C des sommets voisins à NGS 101 : C Cette liste est ordonnée par rapport à la distance 102 : C centre-NGS 103 : C Cette liste ne doit pas contenir la liste des centres 104 : C voisins à NGS 105 : C 106 : C 107 : C NBTPOI = le vrai nombre de point de MLESBC 108 : NBTPOI=0 109 : C 110 : C**** IPLSB1 (IPLSB2) = position de NGS dans la structure MLELSB 111 : C IPOS = position de NGS dans la structure MLESBC 112 : C 113 : IPLSB2=1 114 : IPOS=1 115 : DO I1 = 1, NBL, 1 116 : C 117 : C******* Les sommets voisins de NGS 118 : C 119 : IPLSB1=IPLSB2 120 : IPLSB2=MLELSB.INDEX(I1+1) 121 : NSVOI=IPLSB2-IPLSB1-1 122 : C 123 : C******* Numero global et local du sommets NGS 124 : C 125 : NGS=MLELSB.LESPOI(IPLSB1) 126 : NLS=MLESOM.LECT(NGS) 127 : MLESBC.INDEX(I1)=IPOS 128 : MLESBC.LESPOI(IPOS)=NGS 129 : MLRDIS.PROG(IPOS)=0.0D0 130 : C 131 : C******* On remplie la liste chaînée avec les centres voisins de NGS 132 : C Ces centres ne doivent pas apparaitre dedans MLESBC 133 : C 134 : IPLSC1=MLELSC.INDEX(NLS) 135 : IPLSC2=MLELSC.INDEX(NLS+1) 136 : NGS1=MLELSC.LESPOI(IPLSC1) 137 : IF(NGS1 .NE. NGS)THEN 138 : C 139 : C********** Erreur de programmation 140 : C En effet, par construction, le position de NGS dans la 141 : C structure MLELSC est la meme que dans MELSOM 142 : C 143 : WRITE(IOIMP,*) 'Subroutine rlevb1.eso' 143 : CALL ERREUR(5) 144 : GOTO 9999 145 : ENDIF 146 : NCVOI=IPLSC2-IPLSC1-1 147 : DO I2 = 1, NCVOI, 1 148 : NGC=MLELSC.LESPOI(IPLSC1+I2) 149 : NLC=MLECEN.LECT(NGC) 150 : IF((NLC.EQ.0).OR.(MLECVO.LECT(NLC).NE.0))THEN 151 : C 152 : C********** Erreur de programmation 153 : C 154 : WRITE(IOIMP,*) 'Subroutine rlevb1.eso' 154 : CALL ERREUR(5) 155 : GOTO 9999 156 : ELSE 157 : MLECVO.LECT(NLC)=LAST 158 : LAST=NLC 159 : ENDIF 160 : ENDDO 161 : C 162 : C******* Les centre voisins de sommets voisins 163 : C 164 : NTOTCV=0 165 : C 166 : C******* Boucle sur les sommets voisins 167 : C 168 : DO I2 = 1, NSVOI, 1 169 : NGS1=MLELSB.LESPOI(IPLSB1+I2) 170 : NLS1=MLESOM.LECT(NGS1) 171 : IPLSC1=MLELSC.INDEX(NLS1) 172 : IPLSC2=MLELSC.INDEX(NLS1+1) 173 : NGS2=MLELSC.LESPOI(IPLSC1) 174 : IF(NGS1 .NE. NGS2)THEN 175 : WRITE(IOIMP,*) 'Subroutine rlevb1.eso' 175 : CALL ERREUR(5) 176 : GOTO 9999 177 : ENDIF 178 : NCVOI=IPLSC2-IPLSC1-1 179 : DO I3 = 1, NCVOI, 1 180 : NGC=MLELSC.LESPOI(IPLSC1+I3) 181 : NLC=MLECEN.LECT(NGC) 182 : IF(NLC.EQ.0)THEN 183 : C 184 : C************* Erreur de programmation 185 : C 186 : WRITE(IOIMP,*) 'Subroutine rlevb1.eso' 186 : CALL ERREUR(5) 187 : GOTO 9999 188 : ELSEIF(MLECVO.LECT(NLC).EQ.0)THEN 189 : MLECVO.LECT(NLC)=LAST 190 : LAST=NLC 191 : NTOTCV=NTOTCV+1 192 : ENDIF 193 : ENDDO 194 : ENDDO 195 : C 196 : C******* La structure MLECVO + LAST contient NTOTCV centres voisins 197 : C des sommets sommets voisins à NGS + les centres de NGS 198 : C Il faut le mettre en ordre par raport à la distance 199 : C 200 : IPCOOR=(IDIM+1)*(NGS-1)+1 201 : XS=MCOORD.XCOOR(IPCOOR) 202 : YS=MCOORD.XCOOR(IPCOOR+1) 203 : IF(IDIM.EQ.3) ZS=MCOORD.XCOOR(IPCOOR+2) 204 : NCMIS=0 205 : DO I2 = 1, NTOTCV, 1 206 : NLC=LAST 207 : LAST=MLECVO.LECT(NLC) 208 : MLECVO.LECT(NLC)=0 209 : NGC=MELCEN.NUM(1,NLC) 210 : IPCOOR=(IDIM+1)*(NGC-1)+1 211 : DXC=MCOORD.XCOOR(IPCOOR)-XS 212 : DYC=MCOORD.XCOOR(IPCOOR+1)-YS 213 : DZC=0.0D0 214 : IF(IDIM.EQ.3) DZC=MCOORD.XCOOR(IPCOOR+2)-ZS 215 : DIST2=(DXC*DXC)+(DYC*DYC)+(DZC*DZC) 216 : C 217 : C********** Position avec la methode directe 218 : C 219 : ICEL=1 220 : 10 CONTINUE 221 : IF(ICEL .GT. NCMIS)THEN 222 : NCMIS=NCMIS+1 223 : MLESBC.LESPOI(IPOS+ICEL)=NGC 224 : MLRDIS.PROG(IPOS+ICEL)=DIST2 225 : ELSE 226 : DIST21=MLRDIS.PROG(IPOS+ICEL) 227 : IF(DIST21 .GT. DIST2)THEN 228 : NCMIS=NCMIS+1 229 : ICEL1=IPOS+NCMIS 230 : DO I3 = 0, NCMIS - ICEL - 1 231 : MLESBC.LESPOI(ICEL1-I3)=MLESBC.LESPOI(ICEL1-I3-1) 232 : MLRDIS.PROG(ICEL1-I3)=MLRDIS.PROG(ICEL1-I3-1) 233 : ENDDO 234 : MLESBC.LESPOI(IPOS+ICEL)=NGC 235 : MLRDIS.PROG(IPOS+ICEL)=DIST2 236 : ELSE 237 : ICEL=ICEL+1 238 : GOTO 10 239 : ENDIF 240 : ENDIF 241 : ENDDO 242 : IF(NCMIS .NE. NTOTCV)THEN 242 : CALL ERREUR(5) 243 : GOTO 9999 244 : ENDIF 245 : C 246 : C******* On nettoie MLECVO 247 : C 248 : 20 CONTINUE 249 : IF(LAST.GT.0)THEN 250 : NLC=LAST 251 : LAST=MLECVO.LECT(NLC) 252 : MLECVO.LECT(NLC)=0 253 : GOTO 20 254 : ELSEIF(LAST .NE. -1)THEN 254 : CALL ERREUR(5) 255 : GOTO 9999 256 : ENDIF 257 : C 258 : C******* Mise a jour de NBTPOI 259 : C 260 : NBTPOI=NBTPOI+NCMIS 261 : IPOS=IPOS+NCMIS+1 262 : ENDDO 263 : NBTPOI=NBTPOI+NBL 264 : MLESBC.INDEX(NBL+1)=IPOS 265 : C 266 : C**** MLESBC surdimensionné 267 : C 268 : SEGADJ MLESBC 269 : JG=NBTPOI 270 : SEGADJ MLRDIS 271 : C 272 : SEGDES MLESBC 273 : SEGDES MLELSC 274 : SEGSUP MLELSB 275 : C 276 : SEGDES MLESOM 277 : SEGSUP MLESOM 278 : SEGDES MELCEN 279 : SEGSUP MLECEN 280 : C 281 : SEGSUP MLECVO 282 : SEGDES MLRDIS 283 : 284 : 9999 RETURN 285 : END 286 : 287 :
© Cast3M 2003 - All rights reserved.
Disclaimer