Sources Esope | Cast3M

chaga2
C CHAGA2    SOURCE    CB215821  20/11/04    21:15:29     10766          
 
C=======================================================================
C=                            C H A G A 2                              =
C=                            -----------                              =
C=                                                                     =
C=  Fonction :                                                         =
C=  ----------                                                         =
C=   Calcule la chaleur totale imposee et la "renormalise" a celle     =
C=   demandee par les modeles de source de chaleur qui le necessite    =
C=   (caracteristique QTOT pour source gaussienne).                    =
C=                                                                     =
C=   La quantite totale de chaleur fournie par les modeles qui ne      =
C=   necessite pas de renormalisation sur leur sous-zone de definition =
C=   doit etre ajoutee a la quantite totale de chaleur demandee.       =
C=                                                                     =
C=  Parametres :  (E)=Entree  (S)=Sortie                               =
C=  ------------                                                       =
C=   IPMODE  (E)   Pointeur du MMODEL a traiter                        =
C=   IPCHSO  (E)   Pointeur du MCHAML de caracteristiques des sources  =
C=   IPCHA1  (E)   Pointeur du MCHAML de flux de chaleur integres      =
C=   IPCHA2  (S)   Pointeur du MCHAML de flux de chaleur "renormalise" =
C=                                                                     =
C=======================================================================
 
      SUBROUTINE CHAGA2(IPMODE,IPCHSO,IPCHA1,IPCHA2)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHAML
-INC SMMODEL
-INC CCREEL
 
      CHARACTER*4 MQTOT(1)
      CHARACTER*(LOCOMP) CHACOM
 
      DATA MQTOT /'QTOT'/
 
      SEGMENT TRAVSP1
        INTEGER LNCONS(NS1)
      ENDSEGMENT
      SEGMENT TRAVSP2
        REAL*8  LQCONS(NC1)
      ENDSEGMENT
 
C=====
C Initialisations
C=====
      MMODEL = IPMODE
      NSOU   = KMODEL(/1)
      MCHELM = IPCHSO
      MCHEL1 = IPCHA1
      IPCHA2 = 0
 
C     Segment L(J)=I, Je sous-zone, Ie constituant : mise a zero
      NS1 = NSOU
      SEGINI,TRAVSP1
      DO 1 IS1 = 1,NS1
        LNCONS(IS1) = 0
 1    CONTINUE 
C
C=====
C Precondionnement : identification du nb. de constituants
C     et de leurs sous-zones resp.
C=====
      NBCONS = 0
      DO 10 ISOU = 1,NSOU
        IF (LNCONS(ISOU).NE.0) GOTO 10
        NBCONS = NBCONS + 1
        IMODEL = MMODEL.KMODEL(ISOU)
        NLCONI = IMODEL.CONMOD(/1)
        DO 11 JSOU = ISOU,NSOU
          IF (LNCONS(JSOU).NE.0) GOTO 11
          IMODE1 = MMODEL.KMODEL(JSOU)
          NLCONJ = IMODE1.CONMOD(/1)
          IF (NLCONJ.EQ.NLCONI) THEN
            IF (IMODEL.CONMOD.EQ.IMODE1.CONMOD) THEN
              LNCONS(JSOU) = NBCONS
            ENDIF
          ENDIF
 11     CONTINUE
 10   CONTINUE
c     write(6,*) ' LNCONS =',(LNCONS(i),i=1,nsou)
C
      IF (NBCONS.EQ.0) THEN
        WRITE(IOIMP,*) ' Probleme identification constituants'
        CALL ERREUR(21)
        RETURN
      ENDIF
C
C=====
C Boucle Sommation des flux nodaux de IPCHA1 (MCHEL1)
C=====
C     LQCONS : quantite totale de chaleur par constituant
C
C     Mise a zero de LQCONS
      NC1 = NBCONS
      SEGINI,TRAVSP2
      DO 20 IC1 = 1,NC1
        LQCONS(IC1) = 0.D0
 20   CONTINUE
C
      XQT0 = 0.D0
      XQT1 = 0.D0
      NCON = 0
 
      DO 100 ISOU = 1, NSOU
C
C       Distinction sous-zone modele avec QTOT ou non
        MCHAML = MCHELM.ICHAML(ISOU)
        SEGACT,MCHAML
        N2     = MCHAML.NOMCHE(/2)
        CHACOM = MQTOT(1)
        CALL PLACE(MCHAML.NOMCHE,N2,IPLACE,CHACOM)
        IF (IPLACE.EQ.0) GOTO 100
C
C       Calcul de XQT1
        ICONS  = LNCONS(ISOU)
        MCHAM1 = MCHEL1.ICHAML(ISOU)
        MELVA1 = MCHAM1.IELVAL(1)
        NBPT1  = MELVA1.VELCHE(/1)
        NBEL1  = MELVA1.VELCHE(/2)
        DO 110 IEL1=1,NBEL1
          DO 111 IPT1=1,NBPT1
            LQCONS(ICONS) = LQCONS(ICONS) + MELVA1.VELCHE(IPT1,IEL1)
 111      CONTINUE
 110    CONTINUE
 100  CONTINUE
C======
C Fin boucle somme flux nodaux
C======
C
C
C======
C Boucle Renormalisation
C======
      DO 200 ISOU = 1, NSOU
C       Distinction sous-zone modele avec QTOT ou non
        MCHAML = MCHELM.ICHAML(ISOU)
        N2     = MCHAML.IELVAL(/1)
        CHACOM = MQTOT(1)
        CALL PLACE(MCHAML.NOMCHE,N2,IPLACE,CHACOM)
        IF (IPLACE.EQ.0) GOTO 200
C       XQT0 : Quantite totale de chaleur specifie (QTOT)
        IF (MCHAML.TYPCHE(IPLACE).EQ.'REAL*8') THEN
          MELVAL = IELVAL(IPLACE)
          N1PTEL = MELVAL.VELCHE(/1)
          N1EL   = MELVAL.VELCHE(/2)
          IF (N1PTEL.NE.1.AND.N1EL.NE.1) GOTO 999
          XQT0 = MELVAL.VELCHE(1,1)
c         write(6,*) 'XQT0 =',XQT0
        ELSE
          GOTO 998
        ENDIF
C       XQT1 : Quantite totale de chaleur integree
        ICONS  = LNCONS(ISOU)
        XQT1   = LQCONS(ICONS)
C       Facteur de renormalisation 
        IF (ABS(XQT1).GT.XPETIT) THEN
          XQT1 = XQT0 / XQT1
        ELSE
          XQT1 = 0.D0
        ENDIF
C       Acces au valeurs (MELVAL)
        MCHAM1 = MCHEL1.ICHAML(ISOU)
        MELVA1 = MCHAM1.IELVAL(1)
        NBPT1  = MELVA1.VELCHE(/1)
        NBEL1  = MELVA1.VELCHE(/2)
C       Nouveau MELVAL
        N1PTEL = NBPT1
        N1EL   = NBEL1
        N2PTEL = 0
        N2EL   = 0
        SEGINI,MELVA2
        DO 210 IEL1=1,NBEL1
          DO 211 IPT1=1,NBPT1
            MELVA2.VELCHE(IPT1,IEL1) = XQT1 * MELVA1.VELCHE(IPT1,IEL1)
 211      CONTINUE
 210    CONTINUE
        SEGSUP,MELVA1
        MCHAM1.IELVAL(1) = MELVA2
        SEGACT,MCHAM1*NOMOD
 200  CONTINUE
C======
C fin boucle renormalisation
C======
C
      SEGSUP,TRAVSP1,TRAVSP2
      IPCHA2 = IPCHA1
C
      RETURN
C
C==== Gestion erreurs et fin
 
C     Le nom de la composante ne correspond pas a des variables reelles.
 998  CONTINUE
      CALL ERREUR(671)
      RETURN
C
C     La composante est attendue constante par sous-zones
 999  CONTINUE
      MOTERR(1:4)  = MQTOT(1)
      MOTERR(5:20) = 'CARACTERISTIQUES'
      CALL ERREUR(1065)
      RETURN
 
      END