1 : C CHICLM SOURCE CHAT 05/01/12 21:56:55 5004 2 : SUBROUTINE CHICLM(ICLIM,IDSCHI,IZIADR,MLENT3,LIMP3) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C------------------------------------------------------------------ 6 : C 7 : C PRISE EN COMPTE DES CONDITIONS AUX LIMITES 8 : C IZIADR POINTEUR DE LA LISTE DES ESPECES SIMPLES DE TYPE 3 9 : C MLENT3 POINTEUR DE LA LISTE DES ESPECES SIMPLES A RETENIR 10 : C (CONTENU DE CLIM.COMP3 ) 11 : C LIMP3 POINTEUR DE LA LISTE DES ESPECES IMPOSES EN 3 12 : C (ON A BESOIN DE CETTE INFORMATION DANS CHIMI2) 13 : C 14 : C------------------------------------------------------------------ 15 : -INC SMTABLE 16 : -INC SMLENTI 17 : -INC CCOPTIO 18 : POINTEUR MLIDEN.MLENTI 19 : SEGMENT IDSCHI 20 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 21 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 22 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 23 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 24 : ENDSEGMENT 25 : SEGMENT IZIADR 26 : INTEGER IADR(NCR) 27 : ENDSEGMENT 28 : CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR 29 : LOGICAL LOGRE 30 : C 31 : NCR=0 32 : NYDIM=IDY(/1) 33 : NXDIM=IDX(/1) 34 : NZDIM=IDZ(/1) 35 : NPDIM=IDP(/1) 36 : MTAB1=ICLIM 37 : SEGACT MTAB1 38 : IF(IZIADR.EQ.0) SEGINI IZIADR 39 : NCR=IADR(/1) 40 : LIMP3=0 41 : NL=0 42 : IVALI=1 43 : XVALI=0.D0 44 : IRETI=0 45 : IVALR=0 46 : XVALR=0.D0 47 : IRETR=0 48 : MTYPI='MOT ' 49 : MTYPR=' ' 50 : CHARR=' ' 50 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP3',.TRUE., 51 : *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 52 : IF(MTYPR.NE.' ')THEN 53 : IF(MTYPR.EQ.'LISTENTI')THEN 54 : MLENT1=IRETR 55 : SEGACT MLENT1 56 : LIMP3=MLENT1 57 : NL=MLENT1.LECT(/1) 58 : LTYPE=3 59 : DO 40 J=1,NL 60 : IDYT=MLENT1.LECT(J) 61 : II=0 62 : C ON RECHERCHE LE TYPE INITIAL POUR LE CHANGER EN TYPE 3 63 : DO 20 L=1,6 64 : LL=L 65 : IF(NN(L).NE.0)THEN 66 : I0=II+1 67 : II=II+NN(L) 68 : DO 10 I=I0,II 69 : IF(IDY(I).EQ.IDYT)GO TO 30 70 : 10 CONTINUE 71 : ENDIF 72 : 20 CONTINUE 73 : C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' 74 : INTERR(1)=IDYT 74 : CALL ERREUR(772) 75 : RETURN 76 : 30 CONTINUE 77 : C write(6,*)' idyt ll ltype ',IDYT,LL,LTYPE 77 : CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) 78 : 40 CONTINUE 79 : ELSE 80 : MOTERR(1:11)='CLIM TYP3 ' 81 : MOTERR(12:20)='LISTENTI' 81 : CALL ERREUR(627) 82 : RETURN 83 : ENDIF 84 : ENDIF 85 : MLENT3=0 86 : IVALI=1 87 : XVALI=0.D0 88 : IRETI=0 89 : IVALR=0 90 : XVALR=0.D0 91 : IRETR=0 92 : MTYPI='MOT ' 93 : MTYPR=' ' 94 : CHARR=' ' 94 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'COMP3',.TRUE., 95 : *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 96 : IF(MTYPR.NE.' ')THEN 97 : IF(MTYPR.EQ.'LISTENTI')THEN 98 : MLENT3=IRETR 99 : SEGACT MLENT3 100 : NLC=MLENT3.LECT(/1) 101 : IF(NLC.NE.NL)THEN 102 : C WRITE(6,*)' COMP3 NE CORRESPOND PAS A TYP3 ' 103 : MOTERR(1:8)='COMP3 ' 104 : MOTERR(9:16)='TYP3 ' 104 : CALL ERREUR(773) 105 : RETURN 106 : ENDIF 107 : DO 50 J=1,NLC 108 : IDXT= MLENT3.LECT(J) 109 : IDYT= MLENT1.LECT(J) 110 : IF(IDXT.NE.IDYT)THEN 110 : CALL CHIADY(IDX,NXDIM,IDXT,NDX) 111 : IF(NDX.EQ.0)THEN 112 : C WRITE(6,*) IDXT,' N EST PAS UN COMPOSANT DE', IDYT 113 : INTERR(1)=IDXT 114 : INTERR(2)=IDYT 114 : CALL ERREUR(774) 115 : RETURN 116 : ENDIF 116 : CALL CHIADY(IDY,NYDIM,IDYT,NDY) 117 : C write(6,*)' ndx ndy aa',ndx,ndy,aa(ndy,ndx) 118 : IF(AA(NDY,NDX).EQ.0.D0)THEN 119 : C IDXT N EST PAS UNE COMPOSANTE DE IDYT 120 : C WRITE(6,*) IDXT,' N EST PAS UN COMPOSANT DE', IDYT 121 : INTERR(1)=IDXT 122 : INTERR(2)=IDYT 122 : CALL ERREUR(774) 123 : RETURN 124 : ENDIF 125 : ELSE 125 : CALL CHIADY(IDX,NXDIM,IDYT,NDY) 126 : IF(NDY.EQ.0)THEN 127 : C IDYT N EST PAS SIMPLE IL FAUT PRECISER LE COMPOSANT IMMOBILE 128 : C WRITE(6,*) IDYT,' N EST PAS SIMPLE PRECISEZ COMP3 ' 129 : INTERR(1)=IDYT 129 : CALL ERREUR(775) 130 : RETURN 131 : ENDIF 132 : 133 : ENDIF 134 : 50 CONTINUE 135 : SEGDES MLENT1 136 : ELSE 137 : MOTERR(1:11)='CLIM COMP3 ' 138 : MOTERR(12:20)='LISTENTI' 138 : CALL ERREUR(627) 139 : RETURN 140 : ENDIF 141 : ELSE 142 : IF(NL.NE.0)THEN 143 : DO 55 J=1,NL 144 : IDYT=MLENT1.LECT(J) 144 : CALL CHIADY(IDX,NXDIM,IDYT,NDY) 145 : IF(NDY.EQ.0)THEN 146 : C IDYT N EST PAS SIMPLE IL FAUT PRECISER LA COMPOSANTE IMMOBILE 147 : C WRITE(6,*) IDYT,' N EST PAS SIMPLE PRECISEZ COMP3 ' 148 : INTERR(1)=IDYT 148 : CALL ERREUR(775) 149 : RETURN 150 : ENDIF 151 : 55 CONTINUE 152 : SEGDES MLENT1 153 : ENDIF 154 : ENDIF 155 : IVALI=1 156 : XVALI=0.D0 157 : IRETI=0 158 : IVALR=0 159 : XVALR=0.D0 160 : IRETR=0 161 : MTYPI='MOT ' 162 : MTYPR=' ' 163 : CHARR=' ' 163 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP6',.TRUE., 164 : *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 165 : IF(MTYPR.NE.' ')THEN 166 : IF(MTYPR.EQ.'LISTENTI')THEN 167 : MLENT2=IRETR 168 : SEGACT MLENT2 169 : NL=MLENT2.LECT(/1) 170 : LTYPE=6 171 : DO 90 J=1,NL 172 : IDYT=MLENT2.LECT(J) 173 : II=0 174 : DO 70 L=1,6 175 : LL=L 176 : IF(NN(L).NE.0)THEN 177 : I0=II+1 178 : II=II+NN(L) 179 : DO 60 I=I0,II 180 : IF(IDY(I).EQ.IDYT)GO TO 80 181 : 60 CONTINUE 182 : ENDIF 183 : 70 CONTINUE 184 : C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' 185 : INTERR(1)=IDYT 185 : CALL ERREUR(772) 186 : RETURN 187 : 80 CONTINUE 187 : CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) 188 : C SI IADR EXISTE ON ENLEVE IDYT DE CETTE LISTE 189 : IF(IZIADR.NE.0)THEN 189 : CALL CHIADY(IADR,NCR,IDYT,JJ) 190 : IF(JJ.GT.0)THEN 191 : NCR=NCR-1 192 : DO 85 KJ=JJ,NCR 193 : IADR(KJ)=IADR(KJ+1) 194 : 85 CONTINUE 195 : SEGADJ IZIADR 196 : WRITE(6,*)'chiclm type6 iziadr=',iziadr 197 : ENDIF 198 : ENDIF 199 : 90 CONTINUE 200 : SEGDES MLENT2 201 : ELSE 202 : MOTERR(1:11)='CLIM TYP6 ' 203 : MOTERR(12:20)='LISTENTI' 203 : CALL ERREUR(627) 204 : RETURN 205 : ENDIF 206 : ENDIF 207 : IVALI=1 208 : XVALI=0.D0 209 : IRETI=0 210 : IVALR=0 211 : XVALR=0.D0 212 : IRETR=0 213 : MTYPI='MOT ' 214 : MTYPR=' ' 215 : CHARR=' ' 215 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP4',.TRUE., 216 : *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 217 : IF(MTYPR.NE.' ')THEN 218 : IF(MTYPR.EQ.'LISTENTI')THEN 219 : MLENT2=IRETR 220 : SEGACT MLENT2 221 : NL=MLENT2.LECT(/1) 222 : LTYPE=4 223 : DO 190 J=1,NL 224 : IDYT=MLENT2.LECT(J) 225 : II=0 226 : DO 170 L=1,6 227 : LL=L 228 : IF(NN(L).NE.0)THEN 229 : I0=II+1 230 : II=II+NN(L) 231 : DO 160 I=I0,II 232 : IF(IDY(I).EQ.IDYT)GO TO 180 233 : 160 CONTINUE 234 : ENDIF 235 : 170 CONTINUE 236 : C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' 237 : INTERR(1)=IDYT 237 : CALL ERREUR(772) 238 : RETURN 239 : 180 CONTINUE 239 : CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) 240 : C SI IADR EXISTE ON ENLEVE IDYT DE CETTE LISTE 241 : IF(IZIADR.NE.0)THEN 241 : CALL CHIADY(IADR,NCR,IDYT,JJ) 242 : IF(JJ.GT.0)THEN 243 : NCR=NCR-1 244 : DO 185 KJ=JJ,NCR 245 : IADR(KJ)=IADR(KJ+1) 246 : 185 CONTINUE 247 : SEGADJ IZIADR 248 : write(6,*)'chiclm type4 iziadr=',iziadr 249 : ENDIF 250 : ENDIF 251 : 190 CONTINUE 252 : SEGDES MLENT2 253 : ELSE 254 : MOTERR(1:11)='CLIM TYP4 ' 255 : MOTERR(12:20)='LISTENTI' 255 : CALL ERREUR(627) 256 : RETURN 257 : ENDIF 258 : ENDIF 259 : IVALI=1 260 : XVALI=0.D0 261 : IRETI=0 262 : IVALR=0 263 : XVALR=0.D0 264 : IRETR=0 265 : MTYPI='MOT ' 266 : MTYPR=' ' 267 : CHARR=' ' 267 : CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP5',.TRUE., 268 : *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) 269 : IF(MTYPR.NE.' ')THEN 270 : IF(MTYPR.EQ.'LISTENTI')THEN 271 : MLENT2=IRETR 272 : SEGACT MLENT2 273 : NL=MLENT2.LECT(/1) 274 : LTYPE=5 275 : DO 290 J=1,NL 276 : IDYT=MLENT2.LECT(J) 277 : II=0 278 : DO 270 L=1,6 279 : LL=L 280 : IF(NN(L).NE.0)THEN 281 : I0=II+1 282 : II=II+NN(L) 283 : DO 260 I=I0,II 284 : IF(IDY(I).EQ.IDYT)GO TO 280 285 : 260 CONTINUE 286 : ENDIF 287 : 270 CONTINUE 288 : C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' 289 : INTERR(1)=IDYT 289 : CALL ERREUR(772) 290 : RETURN 291 : 280 CONTINUE 291 : CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) 292 : C SI IADR EXISTE ON ENLEVE IDYT DE CETTE LISTE 293 : IF(IZIADR.NE.0)THEN 293 : CALL CHIADY(IADR,NCR,IDYT,JJ) 294 : IF(JJ.GT.0)THEN 295 : NCR=NCR-1 296 : DO 285 KJ=JJ,NCR 297 : IADR(KJ)=IADR(KJ+1) 298 : 285 CONTINUE 299 : SEGADJ IZIADR 300 : write(6,*)'chiclm type5 iziadr=',iziadr 301 : ENDIF 302 : ENDIF 303 : 290 CONTINUE 304 : SEGDES MLENT2 305 : ELSE 306 : MOTERR(1:11)='CLIM TYP5 ' 307 : MOTERR(12:20)='LISTENTI' 307 : CALL ERREUR(627) 308 : RETURN 309 : ENDIF 310 : ENDIF 311 : SEGDES MTAB1 312 : RETURN 313 : END 314 : 315 : 316 : 317 : 318 : 319 : 320 : 321 :
© Cast3M 2003 - All rights reserved.
Disclaimer