C CHICLM SOURCE CHAT 05/01/12 21:56:55 5004 SUBROUTINE CHICLM(ICLIM,IDSCHI,IZIADR,MLENT3,LIMP3) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C------------------------------------------------------------------ C C PRISE EN COMPTE DES CONDITIONS AUX LIMITES C IZIADR POINTEUR DE LA LISTE DES ESPECES SIMPLES DE TYPE 3 C MLENT3 POINTEUR DE LA LISTE DES ESPECES SIMPLES A RETENIR C (CONTENU DE CLIM.COMP3 ) C LIMP3 POINTEUR DE LA LISTE DES ESPECES IMPOSES EN 3 C (ON A BESOIN DE CETTE INFORMATION DANS CHIMI2) C C------------------------------------------------------------------ -INC SMTABLE -INC SMLENTI -INC PPARAM -INC CCOPTIO POINTEUR MLIDEN.MLENTI SEGMENT IDSCHI REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) INTEGER IDECY(NYDIM),IONZ(NXDIM) CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) ENDSEGMENT SEGMENT IZIADR INTEGER IADR(NCR) ENDSEGMENT CHARACTER*8 MTYPI,CHARI,MTYPR,CHARR LOGICAL LOGRE C NCR=0 NYDIM=IDY(/1) NXDIM=IDX(/1) NZDIM=IDZ(/1) NPDIM=IDP(/1) MTAB1=ICLIM SEGACT MTAB1 IF(IZIADR.EQ.0) SEGINI IZIADR NCR=IADR(/1) LIMP3=0 NL=0 IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 IRETR=0 MTYPI='MOT ' MTYPR=' ' CHARR=' ' CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP3',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) IF(MTYPR.NE.' ')THEN IF(MTYPR.EQ.'LISTENTI')THEN MLENT1=IRETR SEGACT MLENT1 LIMP3=MLENT1 NL=MLENT1.LECT(/1) LTYPE=3 DO 40 J=1,NL IDYT=MLENT1.LECT(J) II=0 C ON RECHERCHE LE TYPE INITIAL POUR LE CHANGER EN TYPE 3 DO 20 L=1,6 LL=L IF(NN(L).NE.0)THEN I0=II+1 II=II+NN(L) DO 10 I=I0,II IF(IDY(I).EQ.IDYT)GO TO 30 10 CONTINUE ENDIF 20 CONTINUE C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' INTERR(1)=IDYT CALL ERREUR(772) RETURN 30 CONTINUE C write(6,*)' idyt ll ltype ',IDYT,LL,LTYPE CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) 40 CONTINUE ELSE MOTERR(1:11)='CLIM TYP3 ' MOTERR(12:20)='LISTENTI' CALL ERREUR(627) RETURN ENDIF ENDIF MLENT3=0 IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 IRETR=0 MTYPI='MOT ' MTYPR=' ' CHARR=' ' CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'COMP3',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) IF(MTYPR.NE.' ')THEN IF(MTYPR.EQ.'LISTENTI')THEN MLENT3=IRETR SEGACT MLENT3 NLC=MLENT3.LECT(/1) IF(NLC.NE.NL)THEN C WRITE(6,*)' COMP3 NE CORRESPOND PAS A TYP3 ' MOTERR(1:8)='COMP3 ' MOTERR(9:16)='TYP3 ' CALL ERREUR(773) RETURN ENDIF DO 50 J=1,NLC IDXT= MLENT3.LECT(J) IDYT= MLENT1.LECT(J) IF(IDXT.NE.IDYT)THEN CALL CHIADY(IDX,NXDIM,IDXT,NDX) IF(NDX.EQ.0)THEN C WRITE(6,*) IDXT,' N EST PAS UN COMPOSANT DE', IDYT INTERR(1)=IDXT INTERR(2)=IDYT CALL ERREUR(774) RETURN ENDIF CALL CHIADY(IDY,NYDIM,IDYT,NDY) C write(6,*)' ndx ndy aa',ndx,ndy,aa(ndy,ndx) IF(AA(NDY,NDX).EQ.0.D0)THEN C IDXT N EST PAS UNE COMPOSANTE DE IDYT C WRITE(6,*) IDXT,' N EST PAS UN COMPOSANT DE', IDYT INTERR(1)=IDXT INTERR(2)=IDYT CALL ERREUR(774) RETURN ENDIF ELSE CALL CHIADY(IDX,NXDIM,IDYT,NDY) IF(NDY.EQ.0)THEN C IDYT N EST PAS SIMPLE IL FAUT PRECISER LE COMPOSANT IMMOBILE C WRITE(6,*) IDYT,' N EST PAS SIMPLE PRECISEZ COMP3 ' INTERR(1)=IDYT CALL ERREUR(775) RETURN ENDIF ENDIF 50 CONTINUE SEGDES MLENT1 ELSE MOTERR(1:11)='CLIM COMP3 ' MOTERR(12:20)='LISTENTI' CALL ERREUR(627) RETURN ENDIF ELSE IF(NL.NE.0)THEN DO 55 J=1,NL IDYT=MLENT1.LECT(J) CALL CHIADY(IDX,NXDIM,IDYT,NDY) IF(NDY.EQ.0)THEN C IDYT N EST PAS SIMPLE IL FAUT PRECISER LA COMPOSANTE IMMOBILE C WRITE(6,*) IDYT,' N EST PAS SIMPLE PRECISEZ COMP3 ' INTERR(1)=IDYT CALL ERREUR(775) RETURN ENDIF 55 CONTINUE SEGDES MLENT1 ENDIF ENDIF IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 IRETR=0 MTYPI='MOT ' MTYPR=' ' CHARR=' ' CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP6',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) IF(MTYPR.NE.' ')THEN IF(MTYPR.EQ.'LISTENTI')THEN MLENT2=IRETR SEGACT MLENT2 NL=MLENT2.LECT(/1) LTYPE=6 DO 90 J=1,NL IDYT=MLENT2.LECT(J) II=0 DO 70 L=1,6 LL=L IF(NN(L).NE.0)THEN I0=II+1 II=II+NN(L) DO 60 I=I0,II IF(IDY(I).EQ.IDYT)GO TO 80 60 CONTINUE ENDIF 70 CONTINUE C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' INTERR(1)=IDYT CALL ERREUR(772) RETURN 80 CONTINUE CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) C SI IADR EXISTE ON ENLEVE IDYT DE CETTE LISTE IF(IZIADR.NE.0)THEN CALL CHIADY(IADR,NCR,IDYT,JJ) IF(JJ.GT.0)THEN NCR=NCR-1 DO 85 KJ=JJ,NCR IADR(KJ)=IADR(KJ+1) 85 CONTINUE SEGADJ IZIADR WRITE(6,*)'chiclm type6 iziadr=',iziadr ENDIF ENDIF 90 CONTINUE SEGDES MLENT2 ELSE MOTERR(1:11)='CLIM TYP6 ' MOTERR(12:20)='LISTENTI' CALL ERREUR(627) RETURN ENDIF ENDIF IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 IRETR=0 MTYPI='MOT ' MTYPR=' ' CHARR=' ' CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP4',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) IF(MTYPR.NE.' ')THEN IF(MTYPR.EQ.'LISTENTI')THEN MLENT2=IRETR SEGACT MLENT2 NL=MLENT2.LECT(/1) LTYPE=4 DO 190 J=1,NL IDYT=MLENT2.LECT(J) II=0 DO 170 L=1,6 LL=L IF(NN(L).NE.0)THEN I0=II+1 II=II+NN(L) DO 160 I=I0,II IF(IDY(I).EQ.IDYT)GO TO 180 160 CONTINUE ENDIF 170 CONTINUE C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' INTERR(1)=IDYT CALL ERREUR(772) RETURN 180 CONTINUE CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) C SI IADR EXISTE ON ENLEVE IDYT DE CETTE LISTE IF(IZIADR.NE.0)THEN CALL CHIADY(IADR,NCR,IDYT,JJ) IF(JJ.GT.0)THEN NCR=NCR-1 DO 185 KJ=JJ,NCR IADR(KJ)=IADR(KJ+1) 185 CONTINUE SEGADJ IZIADR write(6,*)'chiclm type4 iziadr=',iziadr ENDIF ENDIF 190 CONTINUE SEGDES MLENT2 ELSE MOTERR(1:11)='CLIM TYP4 ' MOTERR(12:20)='LISTENTI' CALL ERREUR(627) RETURN ENDIF ENDIF IVALI=1 XVALI=0.D0 IRETI=0 IVALR=0 XVALR=0.D0 IRETR=0 MTYPI='MOT ' MTYPR=' ' CHARR=' ' CALL ACCTAB(MTAB1,MTYPI,IVALI,XVALI,'TYP5',.TRUE., *IRETI,MTYPR,IVALR,XVALR,CHARR,LOGRE,IRETR) IF(MTYPR.NE.' ')THEN IF(MTYPR.EQ.'LISTENTI')THEN MLENT2=IRETR SEGACT MLENT2 NL=MLENT2.LECT(/1) LTYPE=5 DO 290 J=1,NL IDYT=MLENT2.LECT(J) II=0 DO 270 L=1,6 LL=L IF(NN(L).NE.0)THEN I0=II+1 II=II+NN(L) DO 260 I=I0,II IF(IDY(I).EQ.IDYT)GO TO 280 260 CONTINUE ENDIF 270 CONTINUE C WRITE(6,*) IDYT,' N EST PAS UNE ESPECE CONNUE ' INTERR(1)=IDYT CALL ERREUR(772) RETURN 280 CONTINUE CALL CHIREX(IDSCHI,IDYT,LL,LTYPE) C SI IADR EXISTE ON ENLEVE IDYT DE CETTE LISTE IF(IZIADR.NE.0)THEN CALL CHIADY(IADR,NCR,IDYT,JJ) IF(JJ.GT.0)THEN NCR=NCR-1 DO 285 KJ=JJ,NCR IADR(KJ)=IADR(KJ+1) 285 CONTINUE SEGADJ IZIADR write(6,*)'chiclm type5 iziadr=',iziadr ENDIF ENDIF 290 CONTINUE SEGDES MLENT2 ELSE MOTERR(1:11)='CLIM TYP5 ' MOTERR(12:20)='LISTENTI' CALL ERREUR(627) RETURN ENDIF ENDIF SEGDES MTAB1 RETURN END