1 : C CHMREX SOURCE CHAT 05/01/12 21:59:56 5004 2 : SUBROUTINE CHMREX(IDSCHI,IGKMOD,IGKTMP,ID,LINIT,LEND) 3 : C======================================================================= 4 : C ISSU DE TRIOEF (TREXTY) 5 : C PRISE EN COMPTE DE LA 6 : C TEMPERATURE (POUR BDD MINEQL ET POUR BDD STRASBOURG) 7 : C 8 : C OBJET: CHANGE LE TYPE D'ESPECE DE L'ESPECE ID 9 : C 10 : C ARGUMENTS: 11 : C IDSCHI =POINTEUR DU SEGMENT 12 : C IGKMOD= POINTEUR DU SEGMENT CONTENANT LES DONNEES TEMPERATURE 13 : C IGKTMP 14 : C LGKMOD POUR MINEQL 15 : C LGKTMP POUR STRASBOURG 16 : C ID =N› DE L'ESPECE CONCERNE, APPARTIENT AU TABLEAU IDY 17 : C LINIT =TYPE D'ESPECE ACTUEL 18 : C LEND =TYPE D'ESPECE FINAL 19 : C 20 : C 21 : C CETTE SUBROUTINE MODIFIE CERTAIN TABLEAUX CONCERNANT LES ESPECES, 22 : C TELS QUE NN, IDY, ETC... 23 : C 24 : C====================================================================== 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8(A-H,O-Z) 27 : SEGMENT IDSCHI 28 : REAL*8 GK(NYDIM),AA(NYDIM,NXDIM),FF(NZDIM,NPDIM) 29 : INTEGER IDX(NXDIM),IDY(NYDIM),IDZ(NZDIM),IDP(NPDIM),NN(6) 30 : INTEGER IDECY(NYDIM),IONZ(NXDIM) 31 : CHARACTER*32 NAME(NXDIM),NAMESP(NYDIM) 32 : ENDSEGMENT 33 : SEGMENT LGKMOD 34 : REAL*8 DELH0(NYDIM),DELCP0(NYDIM) 35 : ENDSEGMENT 36 : SEGMENT LGKTMP 37 : INTEGER NUMT(NYDIM),NTVT(NYDIM) 38 : REAL*8 TMIMA(NYDIM,NT) 39 : REAL*8 POLYT(NYDIM,NT4),TGKLU(NYDIM,NT) 40 : ENDSEGMENT 41 : SEGMENT IBID 42 : REAL*8 TLU(NT4) 43 : ENDSEGMENT 44 : CHARACTER*32 NAMINT 45 : C 46 : 47 : C 48 : * WRITE(6,*)' ID',ID,'LINIT',LINIT,'LEND',LEND 49 : 50 : IF (LINIT.EQ.LEND) RETURN 51 : NXDIM=IDX(/1) 52 : NYDIM=IDY(/1) 53 : NZDIM=IDZ(/1) 54 : NPDIM=IDP(/1) 54 : CALL CHIADY(IDY,NYDIM,ID,IJ) 54 : IF(IJ.EQ.0)CALL ERREUR(21) 55 : C 56 : K=1 57 : II=0 58 : C 59 : DO 940 LL=1,LINIT 60 : 940 II=II+NN(LL) 61 : III=II-NN(LINIT)+1 62 : * WRITE(6,*)' II ',II,' III ',III,' IJ',IJ,' CHMREX ' 63 : IF (IJ.LT.III.OR.IJ.GT.II) THEN 63 : CALL ERREUR(22) 64 : RETURN 65 : ENDIF 66 : IF (LEND.LE.LINIT) THEN 67 : K=-1 68 : II=III 69 : ENDIF 70 : C 71 : NN(LINIT)=NN(LINIT)-1 72 : NN(LEND)=NN(LEND)+1 73 : LINIT2= LINIT+K 74 : IJDD= IJ 75 : IIDD= II 76 : DO 930 LL= LINIT2,LEND,K 77 : C 77 : C ANCIEN CALL TREXROW(SP1,SP2,LOGKMOD,I,II) 78 : C 79 : I0=IJ 80 : IV=IDY(II) 81 : IDY(II)=IDY(I0) 82 : IDY(I0)=IV 83 : IV=IDECY(II) 84 : IDECY(II)=IDECY(I0) 85 : IDECY(I0)=IV 86 : * WRITE(6,*) '------ IDY(I0): ',IDY(I0) 87 : DO 46 J=1,NXDIM 88 : V=AA(I0,J) 89 : AA(I0,J)=AA(II,J) 90 : AA(II,J)=V 91 : 46 CONTINUE 92 : V=GK(I0) 93 : GK(I0)=GK(II) 94 : GK(II)=V 95 : NAMINT=NAMESP(I0) 96 : NAMESP(I0)=NAMESP(II) 97 : NAMESP(II)=NAMINT 98 : IJ=II 99 : II=II+K*NN(LL) 100 : 930 CONTINUE 101 : C 102 : C 103 : IF(IGKMOD.GT.0)THEN 104 : LGKMOD=IGKMOD 105 : IJ= IJDD 106 : II= IIDD 107 : DO 950 LL= LINIT2,LEND,K 108 : I0=IJ 109 : V=DELH0(I0) 110 : DELH0(I0)=DELH0(II) 111 : DELH0(II)=V 112 : V=DELCP0(I0) 113 : DELCP0(I0)=DELCP0(II) 114 : DELCP0(II)=V 115 : IJ=II 116 : II=II+K*NN(LL) 117 : 950 CONTINUE 118 : ENDIF 119 : C 120 : C 121 : IF(IGKTMP.GT.0)THEN 122 : LGKTMP=IGKTMP 123 : NT=TGKLU(/2) 124 : NT4=NT*4 125 : SEGINI IBID 126 : IJ= IJDD 127 : II= IIDD 128 : DO 960 LL= LINIT2,LEND,K 129 : I0=IJ 130 : JI=NTVT(I0) 131 : NTVT(I0)=NTVT(II) 132 : NTVT(II)=JI 133 : JI=NUMT(I0) 134 : NUMT(I0)=NUMT(II) 135 : NUMT(II)=JI 136 : DO 13 IK=1,NT 137 : TLU(IK)=TMIMA(I0,IK) 138 : TMIMA(I0,IK)=TMIMA(II,IK) 139 : TMIMA(II,IK)=TLU(IK) 140 : 13 CONTINUE 141 : DO 11 IK=1,NT 142 : TLU(IK)=TGKLU(I0,IK) 143 : TGKLU(I0,IK)=TGKLU(II,IK) 144 : TGKLU(II,IK)=TLU(IK) 145 : 11 CONTINUE 146 : DO 12 IK=1,NT*4 147 : TLU(IK)=POLYT(I0,IK) 148 : POLYT(I0,IK)=POLYT(II,IK) 149 : POLYT(II,IK)=TLU(IK) 150 : 12 CONTINUE 151 : C 152 : C FIN DE TREXROW SOURCE 153 : IJ=II 154 : II=II+K*NN(LL) 155 : 960 CONTINUE 156 : SEGSUP IBID 157 : ENDIF 158 : RETURN 159 : END 160 : 161 : 162 :
© Cast3M 2003 - All rights reserved.
Disclaimer