SpectraRust/tlusty/extracted/prchan.f
2026-03-19 14:05:33 +08:00

87 lines
2.4 KiB
Fortran

SUBROUTINE PRCHAN(CHANG,CHM,CHMT)
C =================================
C
C Diagnostic output of relative changes of vector PSI
C
C Input:
C CHANG - array of relative changes of vector PSI at depth ID
C ID - depth index
C Output:
C CHM - maximum relative change of all unknowns at all depths
C CHMT - maximum relative change in temperature at all depths
C
INCLUDE 'IMPLIC.FOR'
INCLUDE 'BASICS.FOR'
INCLUDE 'ATOMIC.FOR'
INCLUDE 'MODELQ.FOR'
INCLUDE 'ITERAT.FOR'
DIMENSION CHANG(MTOT,MDEPTH),CHANM(MDEPTH)
C
C maximum relative change of all unknowns in depth ID
C
CHMT=0.
I1=1
if(icompt.gt.0.and.icombc.gt.0.and.ijex(1).gt.0) i1=2
DO ID=ND,1,-1
CH=0.
chrad=0.
chpop=0.
cht=0.
che=0.
DO 10 I=i1,NN
IF(ITER.EQ.1.AND.I.EQ.NFREQE+INDL) GO TO 10
IF(I.GE.NFREQE+INSE) THEN
II=INDLGZ(I-NFREQE-INSE+1)
IF(RPOP0(II,ID).LT.POPZCH) GO TO 10
END IF
IF(ABS(CHANG(I,ID)).LT.ABS(CH)) GO TO 10
CH=CHANG(I,ID)
10 CONTINUE
CHANM(ID)=CH
IF(NFREQE.GT.0) THEN
DO 11 I=i1,NFREQE
IF(ABS(CHANG(I,ID)).LT.ABS(CHRAD)) GO TO 11
CHRAD=CHANG(I,ID)
jjr=i
11 CONTINUE
END IF
DO 12 I=NFREQE+INSE,NFREQE+INSE+NLVEXZ-1
II=INDLGZ(I-NFREQE-INSE+1)
IF(RPOP0(II,ID).LT.POPZCH) GO TO 12
IF(ABS(CHANG(I,ID)).LT.ABS(CHPOP)) GO TO 12
CHpop=CHANG(I,ID)
jjp=ii
12 CONTINUE
if(inre.gt.0) then
cht=chang(nfreqe+inre,id)
if(abs(cht).ge.abs(chmt)) chmt=abs(cht)
end if
if(inpc.gt.0) che=chang(nfreqe+inpc,id)
C
C output onto file 9
C
IF(ID.EQ.ND.AND.ITER.EQ.1) WRITE(9,800)
WRITE(9,801) ITER,ID,cht,che,CHpop,CHrad,ch,jjp,jjr
800 FORMAT(' RELATIVE CHANGES OF VECTOR PSI'/
* ' ITER ID TEMP NE POP RAD MAXIMUM',
* ' ilev ifr',/)
801 FORMAT(2I5,1P5e10.2,2i5)
END DO
C
C determination of the maximum relative change of all unknowns
C at all depths
C
CHM=0.
DO I=1,ND
IF(ABS(CHANM(I)).GE.ABS(CHM)) CHM=CHANM(I)
END DO
C
if(chmt.lt.chmaxt) then
do itl=iter,niter+1
nitlam(itl)=nlamt
end do
end if
RETURN
END