Sources Esope | Cast3M

chmrex
C CHMREX    SOURCE    CHAT      05/01/12    21:59:56     5004
      SUBROUTINE CHMREX(IDSCHI,IGKMOD,IGKTMP,ID,LINIT,LEND)
C=======================================================================
C      ISSU DE TRIOEF (TREXTY)
C PRISE EN COMPTE DE LA
C TEMPERATURE (POUR BDD MINEQL ET POUR BDD STRASBOURG)
C
C OBJET: CHANGE LE TYPE D'ESPECE DE L'ESPECE ID
C
C ARGUMENTS:
C     IDSCHI =POINTEUR DU SEGMENT
C     IGKMOD= POINTEUR DU SEGMENT CONTENANT LES DONNEES TEMPERATURE
C     IGKTMP
C                         LGKMOD POUR MINEQL
C                         LGKTMP POUR STRASBOURG
C     ID     =N DE L'ESPECE CONCERNE, APPARTIENT AU TABLEAU IDY
C     LINIT  =TYPE D'ESPECE ACTUEL
C     LEND   =TYPE D'ESPECE FINAL
C
C
C CETTE SUBROUTINE MODIFIE CERTAIN TABLEAUX CONCERNANT LES ESPECES,
C TELS QUE NN, IDY, ETC...
C
C======================================================================
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      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 LGKMOD
           REAL*8 DELH0(NYDIM),DELCP0(NYDIM)
      ENDSEGMENT
      SEGMENT LGKTMP
           INTEGER NUMT(NYDIM),NTVT(NYDIM)
           REAL*8 TMIMA(NYDIM,NT)
           REAL*8 POLYT(NYDIM,NT4),TGKLU(NYDIM,NT)
      ENDSEGMENT
      SEGMENT IBID
           REAL*8 TLU(NT4)
      ENDSEGMENT
      CHARACTER*32 NAMINT
C
 
C
*      WRITE(6,*)' ID',ID,'LINIT',LINIT,'LEND',LEND
 
      IF (LINIT.EQ.LEND) RETURN
      NXDIM=IDX(/1)
      NYDIM=IDY(/1)
      NZDIM=IDZ(/1)
      NPDIM=IDP(/1)
      CALL CHIADY(IDY,NYDIM,ID,IJ)
      IF(IJ.EQ.0)CALL ERREUR(21)
C
      K=1
      II=0
C
      DO 940 LL=1,LINIT
940   II=II+NN(LL)
      III=II-NN(LINIT)+1
*     WRITE(6,*)' II ',II,' III ',III,' IJ',IJ,' CHMREX '
      IF (IJ.LT.III.OR.IJ.GT.II) THEN
          CALL ERREUR(22)
          RETURN
      ENDIF
      IF (LEND.LE.LINIT) THEN
            K=-1
            II=III
      ENDIF
C
      NN(LINIT)=NN(LINIT)-1
      NN(LEND)=NN(LEND)+1
      LINIT2= LINIT+K
      IJDD= IJ
      IIDD= II
      DO 930 LL= LINIT2,LEND,K
C
C ANCIEN CALL TREXROW(SP1,SP2,LOGKMOD,I,II)
C
      I0=IJ
      IV=IDY(II)
      IDY(II)=IDY(I0)
      IDY(I0)=IV
      IV=IDECY(II)
      IDECY(II)=IDECY(I0)
      IDECY(I0)=IV
*     WRITE(6,*) '------ IDY(I0): ',IDY(I0)
      DO 46 J=1,NXDIM
         V=AA(I0,J)
         AA(I0,J)=AA(II,J)
         AA(II,J)=V
 46   CONTINUE
      V=GK(I0)
      GK(I0)=GK(II)
      GK(II)=V
      NAMINT=NAMESP(I0)
      NAMESP(I0)=NAMESP(II)
      NAMESP(II)=NAMINT
      IJ=II
      II=II+K*NN(LL)
 930  CONTINUE
C
C
      IF(IGKMOD.GT.0)THEN
         LGKMOD=IGKMOD
         IJ= IJDD
         II= IIDD
         DO 950 LL= LINIT2,LEND,K
               I0=IJ
               V=DELH0(I0)
               DELH0(I0)=DELH0(II)
               DELH0(II)=V
               V=DELCP0(I0)
               DELCP0(I0)=DELCP0(II)
               DELCP0(II)=V
               IJ=II
               II=II+K*NN(LL)
 950     CONTINUE
      ENDIF
C
C
      IF(IGKTMP.GT.0)THEN
      LGKTMP=IGKTMP
      NT=TGKLU(/2)
      NT4=NT*4
      SEGINI IBID
      IJ= IJDD
      II= IIDD
      DO 960 LL= LINIT2,LEND,K
            I0=IJ
            JI=NTVT(I0)
            NTVT(I0)=NTVT(II)
            NTVT(II)=JI
            JI=NUMT(I0)
            NUMT(I0)=NUMT(II)
            NUMT(II)=JI
            DO 13 IK=1,NT
               TLU(IK)=TMIMA(I0,IK)
               TMIMA(I0,IK)=TMIMA(II,IK)
               TMIMA(II,IK)=TLU(IK)
  13        CONTINUE
            DO 11 IK=1,NT
               TLU(IK)=TGKLU(I0,IK)
               TGKLU(I0,IK)=TGKLU(II,IK)
               TGKLU(II,IK)=TLU(IK)
  11        CONTINUE
            DO 12 IK=1,NT*4
               TLU(IK)=POLYT(I0,IK)
               POLYT(I0,IK)=POLYT(II,IK)
               POLYT(II,IK)=TLU(IK)
  12        CONTINUE
C
C FIN DE TREXROW SOURCE
            IJ=II
            II=II+K*NN(LL)
 960  CONTINUE
      SEGSUP IBID
      ENDIF
      RETURN
      END