C BCALQ     SOURCE    CB215821  16/04/21    21:15:15     8920
      SUBROUTINE BCALQ(PE,PVE,TE,PSO,XL,DX0,RUG,Q,XW,NPP,XN,TN,EN,BN,
     $             KIMP,NT,NX,XX,XP,XT,XY,XU,XHF,XQ,XQW,
     $             QAE,XRE,XDH,PSQ,RECU,XKUL,XKUT1,XKUT2,XKUT3,XKUT4)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

C     operateur FUITE
C     cf. sub. BECALC
C     calcul de la solution pour un debit Q d'injection impose
C     QAE, XQ : debit air, debit eau,
C     XQW: flux d'eau a la paroi
C     RECU,XKUL,XKUT1,XKUT2,XKUT3,XKUT4 : coef lois de frot utilisateur
C
      DIMENSION XX(NT),XP(NT),XT(NT),XY(NT),XU(NT),XN(NPP),TN(NPP)
      DIMENSION EN(NPP),BN(NPP)
      DIMENSION XHF(NT),XQ(NT),XQW(NT),XRE(NT),XDH(NT)

      IF(KIMP.GE.2) THEN
        write(6,*) '************************** '
        WRITE(6,*) 'entree bcalq '
      ENDIF
C**   variation enthalpie et puissance echangée avec la paroi
      DHTOT = 0.D0
      PPTOT = 0.D0

      DTMX=10
      PSLIM=0.5*PSO

      PHI = PVE/PE
      CALL BPHYS(T0,P0,RA,RV,CA,CV,CL,XLAT,ROL,XKL,XKT,REL)

C caracteristiques a l'entree
      CALL BCAR(RA,RV,PHI,CV,CA,Q,RQ,R,QA,QV,CPS)

C QAE invariant
      QAE=QA*EN(1)*BN(1)

      ROE = PE/R/TE
      UE=Q/ROE

C>>>  positionnement a l'entree de la fissure

      PSQ=1
      IX=1

      P2=PE
      PV2=PVE
      T2=TE
      U2=UE

      QEE2=QV*EN(1)*BN(1)
      PHI2=PHI

      IF(KIMP.GE.1) THEN
      write(6,*) 'bcalq : Q PHI= ',Q,PHI
      ENDIF

      X=0.D0

      TIT=1
      ITP=1
      NITMAX = 100

C>>>  le gaz a l'entree est-il surchauffe ou sature

      PS2=BPSAT(T2)
      IF (PVE.GT.PS2) THEN
         TIT=0
         Y2=(PS2/(P2-PS2))*(1-PHI)/PHI
      ELSE
         Y2=1
      ENDIF

      QTOT=QEE2+QAE

      CALL BSTOK(IX,X,P2,T2-T0,Y2,U2,0.D0,QEE2,0.D0,0.D0,0.D0,
     &               XX,XP,XT,XY,XU,XHF,XQ,XQW,XRE,XDH,NT)

C>>>  boucle "tant que" sur la longueur de la fissure


  10  CONTINUE
      IF ((X.LT.0.9999).AND.(PSQ.NE.-1.)) THEN
      IF(KIMP.GE.2) THEN
        write(6,*)
        write(6,*) 'bcalq X',X
      ENDIF

C>>>  positionnement au point local 1

         P1=P2
         PS1=BPSAT(T2)
         T1=T2
         Y1=Y2

         QEE1=QEE2
         PHI1=PHI2

         DX=DX0

C>>>  test sur le titre (TIT=1 surchauff ; TIT=0 condens)

         IF (TIT.EQ.1) THEN

             Y2=1
             NIT = 0
  20         CONTINUE
             NIT = NIT + 1
             IF (KIMP.GT.0.AND.NIT.GT.99) THEN
                write(6,*) 'bcalq: NIT20=100 X',X
             ENDIF
             CALL BSUR (X,DX,XL,RUG,XW,XN,TN,EN,BN,KIMP,PSLIM,REL,
     &       RINDEX,P1,T1,QAE,QEE1,PHI1,P2,T2,U2,QEE2,PHI2,QW2,RE,H,PSQ,
     &       NPP,ITP,PF,PP,DPF,DPP,RECU,XKUL,XKUT1,XKUT2,XKUT3,XKUT4)

             IF (PSQ.EQ.-1.) THEN
               IF (KIMP.GT.0) THEN
                 write(6,*) 'bcalq apres bsur PSQ = -1. X P2',X,P2
               ENDIF
               RETURN
             ENDIF

C>>>  y-a-t'il condensation ?

             PS2=BPSAT(T2)
             PSI=PS2/P2
             AL=PHI2/PSI

             IF(KIMP.GE.2) THEN
             WRITE(6,998) X,AL,P2/P0,T2-T0,QEE1/EN(1)/BN(1),
     &       QEE2/EN(1)/BN(1),U2
 998         FORMAT(1X,'sur -XALP2T2 ',2F9.4,E12.5,4F9.2)
             ENDIF

             IF ((RINDEX.LT.0.999).AND.
     &       (NIT.LE.NITMAX)) THEN
                X=X-DX
                DX=DX*0.5
                IF(KIMP.NE.0) THEN
                 write(*,*) 'bcalq RINDEX goto20 NIT= ',NIT
                ENDIF
                GO TO 20
             ENDIF

             IF ((AL.GT.(1.02)).OR.(ABS(T2-T1).GT.DTMX).AND.
     &       (NIT.LE.NITMAX)) THEN
                 X=X-DX
                 DX=DX/2
                IF(KIMP.NE.0) THEN
                 write(*,*) 'bcalq: goto20 X AL NIT ',X, AL,NIT
                ENDIF
                 GOTO 20
             ENDIF

             IF (AL.GT.1.) THEN
               TIT=0
C
               Y2 = (RA/RV)*(QAE/QEE2)*(PSI/(1-PSI))
C
               IF(KIMP.NE.0) THEN
                write(6,*) 'bcalq: transition vers condensation X=  ',X
                write(6,*) 'bcalq: TIT QAE QEE2 ',TIT,QAE,QEE2
                write(6,2100) PS2,AL,Y2
 2100           FORMAT(1X,'bcalq: PS2 AL Y2 ', 3E12.5)
               ENDIF
             ENDIF

         ELSE

             NIT = 0
  30         CONTINUE
             NIT = NIT + 1
             IF (KIMP.GT.0.AND.NIT.GT.99) THEN
                write(6,*) 'bcalq: NIT30=100 X',X
             ENDIF

             CALL BCOND (X,DX,XL,RUG,XW,XN,TN,EN,BN,KIMP,PSLIM,REL,
     &       P1,PS1,T1,Y1,QAE,QEE1,PHI1,
     &       P2,T2,Y2,U2,QEE2,PHI2,QW2,RE,H,PSQ,RINDEX,
     &       NPP,ITP,PF,PP,DPF,DPP,RECU,XKUL,XKUT1,XKUT2,XKUT3,XKUT4)

C            WRITE(6,*)'****** RINDEX,X= ',RINDEX,X

             IF(KIMP.GE.2) THEN
             WRITE(6,999) X,Y2,P2/P0,T2-T0,QEE1/EN(1)/BN(1),
     &       QEE2/EN(1)/BN(1),U2
 999         FORMAT(1X,'cond-XY2P2T2 ',2F9.4,E12.5,4F9.2)
             ENDIF

             IF (PSQ.EQ.-1.) THEN
                RETURN
             ENDIF

             IF ((RINDEX.LT.0.999).AND.
     &       (NIT.LE.NITMAX)) THEN
                X=X-DX
                DX=DX*0.5
                GO TO 30
             ENDIF

C>>>        y-a-t'il evaporation totale ?

             IF ((Y2.GT.(1.01)).OR.(ABS(T2-T1).GT.DTMX).AND.
     &       (NIT.LE.NITMAX)) THEN
                X=X-DX
                DX=DX/2
                IF(KIMP.GE.1) write(6,*) 'bcalq apres bcond Y2DT DX05 X
     &  P2 ',X,P2
                GOTO 30
             ENDIF

* vapeur surchauffee
             IF (Y2.GT.0.999) THEN
               TIT=1
               IF(KIMP.GE.1) write(*,*) 'bcalq:vapeur surchauffee:TIT=1'
* attention si E variable : OK
              IF((QEE2/QAE).LT.1.D-7) THEN
C                write(6,*) ' QEE2/QAE ',QEE2/QAE
                 PHI2=0.D0
              ELSE
                  AA=RA*QAE/RV/QEE2
                 PHI2=1./(1.+AA)
              ENDIF
             ENDIF

         ENDIF

         QTOT=QEE2+QAE

         CALL BSTOK(IX,X,P2,T2-T0,Y2,U2,H,QEE2,QW2,RE,DPF,
     &                XX,XP,XT,XY,XU,XHF,XQ,XQW,XRE,XDH,NT)

      DHTOT = DHTOT + PF
      PPTOT = PPTOT + PP

      GOTO 10
      ENDIF

      NX=IX-1
      PSQ=P2

      XX(NX)=1.D0
C     write(6,*) ' bcalq  NX ',NX
C     CALL UTPRIM(XX,NX)
C**
      IF(KIMP.GT.0) THEN
      WRITE(*,*) 'bcalq: X,PSQ= ',X,PSQ
      ENDIF
      IF(KIMP.GT.1) THEN
      write(6,1000) Q,PHI,DHTOT,PPTOT
 1000 FORMAT(1X,'bcalq Q phi DH H*T',4E12.5)
      ENDIF
C**

      RETURN
      END