1 : C SORT5 SOURCE FANDEUR 10/12/14 21:19:48 6812 2 : SUBROUTINE SORT5(ICOLAC) 3 : C======================================================================= 4 : C RESTAURATION DE LA NUMEROTATION DANS LES PILES 5 : C 6 : C PROGRAMME PAR FARVACQUE 7 : C APPELE PAR REST RESTFO 8 : C N'APPELLE RIEN 9 : C======================================================================= 10 : C TABLEAU KCOLA : 11 : C 1 MELEME 2 CHPOIN 3 MRIGID 4 5 6 MCLSTR 12 : C 7 MELSTR 8 MSOLUT 9 MSTRUC 10 11 12 MSOSTU 13 : C 13 IMATRI 14 MJONCT 15 MATTAC 16 MMATRI 17 MDEFOR 18 MLREEL 14 : C 19 MLENTI 20 MCHARG 21 22 MEVOLL 15 : C======================================================================= 16 : IMPLICIT INTEGER(I-N) 17 : IMPLICIT REAL*8(A-H,O-Z) 18 : -INC CCOPTIO 19 : -INC SMELEME 20 : -INC SMCHPOI 21 : -INC SMRIGID 22 : -INC SMMATRI 23 : -INC SMSOLUT 24 : -INC SMLENTI 25 : -INC SMLREEL 26 : -INC SMDEFOR 27 : -INC SMCHARG 28 : -INC SMEVOLL 29 : -INC TMCOLAC 30 : -INC TMVECRIG 31 : C 32 : SEGMENT ILIST(ILL) 33 : SEGMENT ISORTA(0) 34 : 35 : CHARACTER*(8) ITYPE 36 : C 37 : SEGACT ICOLAC 38 : NITLAC=ICOLA(/1) 39 : C 40 : C **** BOUCLE SUR LES FILES DE SORTIE IFILE=1,NITLAC 41 : C 42 : DO 1099 IFILE=1,NITLAC 43 : ITLACC=KCOLA(IFILE) 44 : IMAX1=ITLAC(/1) 45 : IF(IMAX1.EQ.0) GO TO 1099 46 : IP1=ICOLA(IFILE) 47 : GO TO (6001,6002,6003,1099,1099,1099,1099,6008,1099,1099, 48 : & 1099,1099,6013,1099,1099,6016,6017,6018,6019,6020, 49 : & 1099,6022),IFILE 50 : C Au cas où un ICOLAC plus grand serait passé en argument ... 51 : GOTO 1099 52 : C ****************************** MELEME **************************** 53 : 6001 CONTINUE 54 : DO 20 I=1,IMAX1 55 : MELEME=ITLAC(I) 56 : SEGACT MELEME 57 : IF (LISOUS(/1).EQ.0) GOTO 21 58 : DO 1003 J=1,LISOUS(/1) 59 : LISOUS(J)=ITLAC(LISOUS(J)) 60 : 1003 CONTINUE 61 : 21 CONTINUE 62 : IF (LISREF(/1).EQ.0) GOTO 25 63 : DO 1004 J=1,LISREF(/1) 64 : LISREF(J)=ITLAC(LISREF(J)) 65 : 1004 CONTINUE 66 : 25 CONTINUE 67 : SEGDES MELEME 68 : 20 CONTINUE 69 : GOTO 1098 70 : C **************************CHPOINT********************************* 71 : 6002 CONTINUE 72 : ITLAC1=KCOLA(1) 73 : DO 1101 IEL=1,IMAX1 74 : MCHPOI=ITLAC(IEL) 75 : SEGACT MCHPOI 76 : NSOUPO=IPCHP(/1) 77 : DO 1103 ISOU=1,NSOUPO 78 : MSOUPO=IPCHP(ISOU) 79 : SEGACT MSOUPO 80 : IVA=IGEOC 81 : IGEOC=ITLAC1.ITLAC(IVA) 82 : SEGDES MSOUPO 83 : 1103 CONTINUE 84 : SEGDES MCHPOI 85 : 1101 CONTINUE 86 : GOTO 1098 87 : C ***********************MRIGID************************************* 88 : 6003 CONTINUE 89 : ITLAC1=KCOLA(1) 90 : ITLAC2=KCOLA(13) 91 : ITLAC3=KCOLA(16) 92 : * ITLAC4=KCOLA(11) ON REMPLACE PAR UN MELEME AM 12/2/90 93 : DO 1202 IEL=1,IMAX1 94 : MRIGID=ITLAC(IEL) 95 : SEGACT MRIGID 96 : NRIGEL=IRIGEL(/2) 97 : IF(IMGEO1.EQ.0) GOTO 1204 98 : IMGEOD=IMGEO1 99 : SEGACT IMGEOD 100 : DO 1205 I=1,IMGEOR(/1) 101 : IVA=IMGEOR(I) 102 : IMGEOR(I)=ITLAC1.ITLAC(IVA) 103 : 1205 CONTINUE 104 : SEGDES IMGEOD 105 : 1204 CONTINUE 106 : IF(IMGEO1.EQ.0) GOTO 1208 107 : MVECRI=IVECRI 108 : SEGACT MVECRI*mod 109 : DO 1209 I=1,MELZON(/1) 110 : IVA=MELZON(I) 111 : MELZON(I)=ITLAC1.ITLAC(IVA) 112 : 1209 CONTINUE 113 : SEGDES MVECRI 114 : 1208 CONTINUE 115 : IVA=ICHOLE 116 : IF(IVA .NE.0) ICHOLE=ITLAC3.ITLAC(IVA) 117 : DO 1203 IR=1,NRIGEL 118 : IVA=IRIGEL(1,IR) 119 : IRIGEL(1,IR)=ITLAC1.ITLAC(IVA) 120 : IVA=IRIGEL(2,IR) 121 : IF(IVA.NE.0) IRIGEL(2,IR)=ITLAC1.ITLAC(IVA) 122 : * IVA=IRIGEL(4,IR) 123 : * IRIGEL(4,IR)=ITLAC2.ITLAC(IVA) 124 : 1203 CONTINUE 125 : SEGDES MRIGID 126 : 1202 CONTINUE 127 : GOTO 1098 128 : C *************************** ******************************* 129 : 6004 CONTINUE 130 : GOTO 1098 131 : C *************************** ******************************* 132 : 6005 CONTINUE 133 : GOTO 1098 134 : C ****************************MSOLUT******************************** 135 : 6008 CONTINUE 136 : DO 1800 IEL=1,IMAX1 137 : MSOLUT=ITLAC(IEL) 138 : SEGACT MSOLUT 139 : IF(MSOLIS(3).LE.0) GOTO 1802 140 : ITLAC1=KCOLA(1) 141 : IVA=MSOLIS(3) 142 : MSOLIS(3)=ITLAC1.ITLAC(IVA) 143 : GOTO 1803 144 : 1802 CONTINUE 145 : MSOLIS(3)=-MSOLIS(3) 146 : 1803 CONTINUE 147 : SEGDES MSOLUT 148 : 1800 CONTINUE 149 : GOTO 1098 150 : C ***************************** ***************************** 151 : 6011 CONTINUE 152 : GOTO 1098 153 : C ***************************** IMATRI ***************************** 154 : 6013 CONTINUE 155 : GOTO 1098 156 : C ***************************** MMATRI ***************************** 157 : 6016 CONTINUE 158 : ITLAC1=KCOLA(1) 159 : DO 2600 IEL=1,IMAX1 160 : MMATRI=ITLAC(IEL) 161 : SEGACT MMATRI 162 : IVA=IGEOMA 163 : IGEOMA=ITLAC1.ITLAC(IVA) 164 : SEGDES MMATRI 165 : 2600 CONTINUE 166 : GOTO 1098 167 : C ************************* MDEFOR******************************* 168 : 6017 CONTINUE 169 : ITLAC1=KCOLA(1) 170 : ITLAC2=KCOLA(2) 171 : ITLAC3=KCOLA(30) 172 : ITLAC4=KCOLA(38) 173 : ITLAC5=KCOLA(39) 174 : DO 2700 IEL=1,IMAX1 175 : MDEFOR=ITLAC(IEL) 176 : SEGACT MDEFOR 177 : NDEF=IELDEF(/1) 178 : DO 2701 I=1,NDEF 179 : IVA=IELDEF(I) 180 : IELDEF(I)=ITLAC1.ITLAC(IVA) 181 : IVA=ICHDEF(I) 182 : ICHDEF(I)=ITLAC2.ITLAC(IVA) 183 : IVA=MTVECT(I) 184 : MTVECT(I)=ITLAC3.ITLAC(IVA) 185 : IVA=MDCHP(I) 186 : MDCHP(I)=ITLAC2.ITLAC(IVA) 187 : IVA=MDCHEL(I) 188 : MDCHEL(I)=ITLAC5.ITLAC(IVA) 189 : IVA=MDMODE(I) 190 : MDMODE(I)=ITLAC4.ITLAC(IVA) 191 : 2701 CONTINUE 192 : SEGDES MDEFOR 193 : 2700 CONTINUE 194 : GOTO 1098 195 : C ***************************MLREEL****************************** 196 : 6018 CONTINUE 197 : GOTO 1098 198 : C *****************************MLENTI*************************** 199 : 6019 CONTINUE 200 : GOTO 1098 201 : C ****************************MCHARG***************************** 202 : 6020 CONTINUE 203 : ITLAC1=KCOLA(2) 204 : ITLAC2=KCOLA(18) 205 : ITLAC3=KCOLA(39) 206 : ITLAC4=KCOLA(10) 207 : ITLAC5=KCOLA(32) 208 : ITLAC6=KCOLA(1) 209 : DO 3000 IEL=1,IMAX1 210 : MCHARG=ITLAC(IEL) 211 : SEGACT MCHARG 212 : N=KCHARG(/1) 213 : DO 3001 I=1,N 214 : ICHARG=KCHARG(I) 215 : SEGACT ICHARG 216 : IF(CHATYP.EQ.'CHPOINT ') THEN 217 : IVA=ICHPO1 218 : ICHPO1=ITLAC1.ITLAC(IVA) 219 : IVA=ICHPO2 220 : ICHPO2=ITLAC2.ITLAC(IVA) 221 : IVA=ICHPO3 222 : ICHPO3=ITLAC2.ITLAC(IVA) 223 : ELSE IF (CHATYP.EQ.'MCHAML ') THEN 224 : IVA=ICHPO1 225 : IICHPO1=ITLAC3.ITLAC(IVA) 226 : IVA=ICHPO2 227 : ICHPO2=ITLAC2.ITLAC(IVA) 228 : IVA=ICHPO3 229 : ICHPO3=ITLAC2.ITLAC(IVA) 230 : ELSE IF (CHATYP.EQ.'TABLE ') THEN 231 : IVA=ICHPO1 232 : ICHPO1=ITLAC4.ITLAC(IVA) 233 : IVA=ICHPO2 234 : ICHPO2=ITLAC4.ITLAC(IVA) 235 : ENDIF 236 : IF(CHAMOB(I).EQ.'TRAN') THEN 237 : IVA=ICHPO4 238 : ICHPO4=ITLAC5.ITLAC(IVA) 239 : IVA=ICHPO6 240 : ICHPO6=ITLAC2.ITLAC(IVA) 241 : IVA=ICHPO7 242 : ICHPO7=ITLAC2.ITLAC(IVA) 243 : ELSEIF(CHAMOB(I).EQ.'ROTA') THEN 244 : IVA=ICHPO4 245 : ICHPO4=ITLAC5.ITLAC(IVA) 246 : IVA=ICHPO5 247 : IF(IDIM.GT.2) ICHPO5=ITLAC5.ITLAC(IVA) 248 : IVA=ICHPO6 249 : ICHPO6=ITLAC2.ITLAC(IVA) 250 : IVA=ICHPO7 251 : ICHPO7=ITLAC2.ITLAC(IVA) 252 : ELSEIF(CHAMOB(I).EQ.'TRAJ') THEN 253 : IVA=ICHPO4 254 : ICHPO4=ITLAC1.ITLAC(IVA) 255 : IVA=ICHPO5 256 : ICHPO5=ITLAC6.ITLAC(IVA) 257 : IVA=ICHPO6 258 : ICHPO6=ITLAC2.ITLAC(IVA) 259 : ENDIF 260 : SEGDES ICHARG 261 : 3001 CONTINUE 262 : SEGDES MCHARG 263 : 3000 CONTINUE 264 : GOTO 1098 265 : C ************************ ***************************** 266 : 6021 CONTINUE 267 : GOTO 1098 268 : C *********************MEVOLL************************************ 269 : 6022 CONTINUE 270 : ITLAC1=KCOLA(1) 271 : ITLAC2=KCOLA(18) 272 : DO 3200 IEL=1,IMAX1 273 : MEVOLL=ITLAC(IEL) 274 : SEGACT MEVOLL 275 : N=IEVOLL(/1) 276 : DO 3201 I=1,N 277 : KEVOLL=IEVOLL(I) 278 : SEGACT KEVOLL 279 : IVA=IPROGX 280 : IPROGX=ITLAC2.ITLAC(IVA) 281 : IVA=IPROGY 282 : IPROGY=ITLAC2.ITLAC(IVA) 283 : SEGDES KEVOLL 284 : 3201 CONTINUE 285 : SEGDES MEVOLL 286 : 3200 CONTINUE 287 : GOTO 1098 288 : C ****************************************************************** 289 : 1098 CONTINUE 290 : C 291 : 1099 CONTINUE 292 : SEGDES ICOLAC 293 : C 294 : RETURN 295 : END 296 : 297 :
© Cast3M 2003 - All rights reserved.
Disclaimer