Sources Esope | Cast3M

prim2f
C PRIM2F    SOURCE    CB215821  20/11/25    13:36:54     10792          
       SUBROUTINE PRIM2F()
C************************************************************************
C
C PROJET            :  CASTEM 2000
C
C NOM               :  PRIM
C
C LANGAGE           :  FORTRAN 77 + ESOPE 2000 (avec extensions CISI)
C
C AUTEUR            :  Jose R. Garcia-Cascales,
C                      Universidad Politecnica de Cartagena,
C                      jr.garcia@upct.es
C
C************************************************************************
C
C
C APPELES (E/S)     :
C
C APPELES (Calcul)  :
C
C************************************************************************
C
C PHRASE D'APPEL (GIBIANE) :
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
C
C**** Les variables
C
      INTEGER ICOND, IRETOU, INDIC, NBCOMP,
     &       ICEN, ICH1, ICH2, ICH3,
     &       ICH4, ICH5, ICH6, ICH7,
     &       ICH8, ICH9,
     &       OCH1, OCH2, OCH3,
     &       OCH4, OCH5, OCH6,
     &       OCH7, OCH8, OCH9,
     &       JGN, JGM
      REAL*8 VALER(2),VAL1,VAL2, Cp, Cvm
      CHARACTER*(40) MESERR(2),MESCEL
      CHARACTER*(6) NOMTRI
      LOGICAL LOGNEG, LOGBOR, LOGTRI
C
C**** Les Includes
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLMOTS
C
C**** Initialisation des parametres d'erreur
C
      LOGNEG  = .FALSE.
      LOGBOR  = .FALSE.
      LOGTRI = .FALSE.
      MESCEL = '                                        '
      MESERR(1) = MESCEL
      MESERR(2) = MESCEL
      MOTERR(1:40) = MESCEL
      VALER(1) = 0.0D0
      VALER(2) = 0.0D0
      VAL1 = 0.0D0
      VAL2 = 0.0D0
C
C**** Lecture du CHPOINT ICH1
C
      ICOND = 1
      CALL LIROBJ('CHPOINT ',ICH1,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT ',ICH1,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** On cherche le pointeur de son maillage et on l'impose sur les
C     autres CHPOINT
C
      MCHPOI = ICH1
      SEGACT MCHPOI
      MSOUPO = MCHPOI.IPCHP(1)
      SEGACT MSOUPO
      ICEN = MSOUPO.IGEOC
      SEGDES MSOUPO
      SEGDES MCHPOI
C
C**** On recupere en QUEPO1 MLMOTS
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH1, ICEN, MLMOTS)
C
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR = 'CHPO1 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH2
C
      ICOND = 1
      CALL LIROBJ('CHPOINT ',ICH2,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT ',ICH2,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH2
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH2, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO2 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH3
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH3,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH3,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH3
C
      JGN = 4
      JGM = IDIM
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'UVX'
      MLMOTS.MOTS(2) = 'UVY'
      IF(IDIM .EQ. 3) MLMOTS.MOTS(3) = 'UVZ'
      CALL QUEPO1(ICH3, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO3 = ???                             '
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH4
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH4,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH4,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH4
C
      JGN = 4
      JGM = IDIM
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'ULX'
      MLMOTS.MOTS(2) = 'ULY'
      IF(IDIM .EQ. 3) MLMOTS.MOTS(3) = 'ULZ'
      CALL QUEPO1(ICH4, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO4 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH5
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH5,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH5,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH5
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH5, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO5 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH6
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH6,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH6,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH6
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH6, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO6 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH7
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH7,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH7,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH7
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH7, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO7 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH8
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH8,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH8,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH8
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH8, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO8 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C**** Lecture du CHPOINT ICH9
C
      ICOND = 1
      CALL LIROBJ('CHPOINT',ICH9,ICOND,IRETOU)
      CALL ACTOBJ('CHPOINT',ICH9,1)
      IF (IERR.NE.0) GOTO 9999
C
C**** Control du CHPOINT ICH9
C
      JGN = 4
      JGM = 1
      SEGINI MLMOTS
      MLMOTS.MOTS(1) = 'SCAL'
      CALL QUEPO1(ICH9, ICEN, MLMOTS)
      IF(IERR .NE. 0)THEN
C
C******** Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR  = 'CHPO9 = ???                             '
         WRITE(IOIMP,*) MOTERR(1:40)
 
         GOTO 9999
      ENDIF
      SEGSUP MLMOTS
C
C     Lecture of the CATHARE pressure correction term
C     parameters
C
      ICOND = 1
      CALL LIRREE(Cp,ICOND,IRETOU)
      IF(IERR .NE. 0) GOTO 9999
      IF((Cp .LT. 0) .OR. (Cp .GT. 7.d0))THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'Cp = ???                           '
         CALL ERREUR(-301)
C
C******* Message d'erreur standard
C        Entier valant: %i1
C        -2 0
C
C         INTERR(1) = Cp
      ENDIF
 
      ICOND = 1
      CALL LIRREE(Cvm,ICOND,IRETOU)
      IF(IERR .NE. 0) GOTO 9999
      IF((Cvm .LT. 0) .OR. (Cvm .GT. 7.d0))THEN
C
C******* Message d'erreur standard
C        -301 0 %m1:40
C
         MOTERR(1:40) = 'Cvm = ???                          '
         CALL ERREUR(-301)
C
C******* Message d'erreur standard
C        Entier valant: %i1
C        -2 0
C
C         INTERR(1) = Cvm
      ENDIF
C
C
C**** Calcul des sorties.
C
      CALL PR12f(ICEN, ICH1, ICH2, ICH3,
     &           ICH4, ICH5, ICH6, ICH7,
     &           ICH8, ICH9,
     &           Cp, Cvm,
     &           OCH1, OCH2, OCH3,
     &           OCH4, OCH5, OCH6,
     &           OCH7, OCH8, OCH9,
     &           LOGNEG, LOGBOR, MESERR,
     &           VALER, VAL1, VAL2)
C
      IF(LOGNEG)THEN
C
C******* Pression (energie thermique)  ou densité negative
C
C******* Message d'erreur standard
C        41 2
C        %m1:8 = %r1 inférieur à %r2
C
         MESCEL = MESERR(1)
         MOTERR(1:8) = MESCEL(1:8)
         REAERR(1) = REAL(VALER(1))
         REAERR(2) = 0.0
         CALL ERREUR(41)
         IF(LOGTRI)THEN
*            IERR = 0
         ELSE
            GOTO 9999
         ENDIF
      ENDIF
      IF(LOGBOR)THEN
C
C******* Message d'erreur standard
C        42 2
C        %m1:8 = %r1 non compris entre %r2 et %r3
C
         MESCEL = MESERR(2)
         MOTERR(1:8) = MESCEL(1:8)
         REAERR(1) = REAL(VALER(2))
         REAERR(2) = REAL(VAL1)
         REAERR(3) = REAL(VAL2)
         CALL ERREUR(42)
         IF(LOGTRI)THEN
*            IERR = 0
         ELSE
            GOTO 9999
         ENDIF
      ENDIF
C
C**** Ecriture du CHPOINT contenant la SUMA
C
      CALL ACTOBJ('CHPOINT ', OCH1,1)
      CALL ACTOBJ('CHPOINT ', OCH2,1)
      CALL ACTOBJ('CHPOINT ', OCH3,1)
      CALL ACTOBJ('CHPOINT ', OCH4,1)
      CALL ACTOBJ('CHPOINT ', OCH5,1)
      CALL ACTOBJ('CHPOINT ', OCH6,1)
      CALL ACTOBJ('CHPOINT ', OCH7,1)
      CALL ACTOBJ('CHPOINT ', OCH8,1)
      CALL ACTOBJ('CHPOINT ', OCH9,1)
 
      CALL ECROBJ('CHPOINT ', OCH1)
      CALL ECROBJ('CHPOINT ', OCH2)
      CALL ECROBJ('CHPOINT ', OCH3)
      CALL ECROBJ('CHPOINT ', OCH4)
      CALL ECROBJ('CHPOINT ', OCH5)
      CALL ECROBJ('CHPOINT ', OCH6)
      CALL ECROBJ('CHPOINT ', OCH7)
      CALL ECROBJ('CHPOINT ', OCH8)
      CALL ECROBJ('CHPOINT ', OCH9)
C
 9999 CONTINUE
 
      END