! *********************************************************** ! CALCULATE GLOBAL QUANTITIES ! *********************************************************** SUBROUTINE TRGLOB USE TRCOMM, ONLY : & & ABRHOG, AJ, AJBS, AJBST, AJNB, AJNBT, AJOH, AJOHT, AJRF, AJRFT, & & AJRFV, AJRFVT, AJT, AJTOR, AJTTOR, ALI, ANF0, ANFAV, ANLAV, & & ANS0, ANSAV, BB, BETA, BETA0, BETAA, BETAL, BETAN, BETAP, & & BETAP0, BETAPA, BETAPL, BETAQ, BETAQ0, BP, DD, DR, DVRHO, & & DVRHOG, EZOH, H98Y2, MDLUF, NEQMAX, NFM, NRAMAX, NRMAX, & & NROMAX, NSM, NSS, NSV, PA, PBCL, PBCLT, PBIN, PBINT, PBM, & & PCX, PCXT, PEX, PEXST, PEXT, PFCL, PFCLT, PFIN, PFINT, PI, & & PIE, PIET, PINT, PLT, PNB, PNBT, PNF, PNFT, PNSS, POH, POHT, & & POUT, PRF, PRFST, PRFT, PRFV, PRFVT, PTS, Q0, QF, & & QP, RA, RDP, RG, RHOA, RIP, RKAP, RKEV, RM, RMJRHO, RMU0, RN, & & RNF, RQ1, RR, RT, RW, SIE, SIET, SINT, SLT, SNB, SNBT, SNF, & & SNFT, SOUT, SPE, SPET, T, TAUE1, TAUE2, TAUE89, TAUE98, TF0, & & TFAV, TPRE, TS0, TSAV, VLOOP, VV, WBULKT, WFT, WPDOT, WPPRE, & & WPT, WST, WTAILT, ZEFF, ZEFF0, ABVRHOG, RDPVRHOG, & & PRB,PRC,PRL,PRSUM,PRBT,PRCT,PRLT,PRSUMT IMPLICIT NONE INTEGER(4):: NEQ, NF, NMK, NR, NRL, NS, NSSN, NSSN1, NSVN, NSVN1, NSW, NW REAL(8) :: ANFSUM, C83, DRH, DV53, FCTR, PAI, PLST, RNSUM, RNTSUM, & & RTSUM, RWSUM, SLST, SUMM, SUML, SUMP, VOL, WPOL REAL(8),DIMENSION(NRMAX):: DSRHO IF(RHOA.NE.1.D0) NRMAX=NROMAX ! *** Local beta *** ! BETA : toroidal beta ! BETAL : volume-averaged toroidal beta ! BETAP : poloidal beta ! BETAPL: volume-averaged poloidal beta ! BETAQ : toroidal beta for reaction rate ! (ref. TOKAMAKS 3rd, p115) SUMM=0.D0 SUMP=0.D0 VOL =0.D0 DO NR=1,NRMAX-1 SUML = (SUM(RN(NR,1:NSM)*RT(NR,1:NSM)) + SUM(RW(NR,1:NFM)))*RKEV*1.D20 !! DSRHO(NR)=DVRHO(NR)/(2.D0*PI*RMJRHO(NR)) DSRHO(NR)=DVRHO(NR)/(2.D0*PI*RR) VOL = VOL + DVRHO(NR)*DR SUMM = SUMM + SUML *DVRHO(NR)*DR SUMP = SUMP + SUML**2*DVRHO(NR)*DR BETA(NR) = 2.D0*RMU0*SUMM /( VOL *BB**2) BETAL(NR) = 2.D0*RMU0*SUML /( BB**2) BETAP(NR) = 2.D0*RMU0*SUMM /( VOL *BP(NRMAX)**2) BETAPL(NR) = 2.D0*RMU0*SUML /( BP(NRMAX)**2) BETAQ(NR) = 2.D0*RMU0*SQRT(SUMP)/(SQRT(VOL)*BB**2) ENDDO NR=NRMAX SUML = (SUM(RN(NR,1:NSM)*RT(NR,1:NSM)) + SUM(RW(NR,1:NFM)))*RKEV*1.D20 !! DSRHO(NR)=DVRHO(NR)/(2.D0*PI*RMJRHO(NR)) DSRHO(NR)=DVRHO(NR)/(2.D0*PI*RR) VOL = VOL + DVRHO(NR)*DR SUMM = SUMM + SUML *DVRHO(NR)*DR SUMP = SUMP + SUML**2*DVRHO(NR)*DR BETA(NR) = 2.D0*RMU0*SUMM /( VOL *BB**2) BETAL(NR) = 2.D0*RMU0*SUML /( BB**2) BETAP(NR) = 2.D0*RMU0*SUMM /( VOL *BP(NRMAX)**2) BETAPL(NR) = 2.D0*RMU0*SUML /( BP(NRMAX)**2) BETAQ(NR) = 2.D0*RMU0*SQRT(SUMP)/(SQRT(VOL)*BB**2) BETA0 =(4.D0*BETA(1) -BETA(2) )/3.D0 BETAP0=(4.D0*BETAPL(1)-BETAPL(2))/3.D0 BETAQ0=(4.D0*BETAQ(1) -BETAQ(2) )/3.D0 ! *** Global beta *** ! BETAPA: poloidal beta at separatrix ! BETAA : toroidal beta at separatrix ! BETAN : normalized toroidal beta (Troyon beta) BETAPA=BETAP(NRMAX) BETAA =BETA(NRMAX) BETAN =BETAA*1.D2/(RIP/(RA*BB)) ! *** Volume-averaged density and temperature *** ! *** Central density and temperature *** ! *** Stored energy *** ! +++ for electron and bulk ions +++ DO NS=1,NSM RNSUM = SUM(RN(1:NRMAX,NS)*DVRHO(1:NRMAX)) RTSUM = SUM(RN(1:NRMAX,NS)*RT(1:NRMAX,NS)*DVRHO(1:NRMAX)) ANSAV(NS) = RNSUM*DR/VOL ANS0(NS) = FCTR(RM(1),RM(2),RN(1,NS),RN(2,NS)) IF(RNSUM.GT.0.D0) THEN TSAV(NS) = RTSUM/RNSUM ELSE TSAV(NS) = 0.D0 ENDIF TS0(NS) = FCTR(RM(1),RM(2),RT(1,NS),RT(2,NS)) WST(NS) = 1.5D0*RTSUM*DR*RKEV*1.D14 ENDDO ! +++ for fast particles +++ IF(MDLUF.NE.0) THEN ANFSUM = SUM(RNF(1:NRMAX,1)*DVRHO(1:NRMAX)) RNTSUM = SUM(RNF(1:NRMAX,1)*RT(1:NRMAX,2)*DVRHO(1:NRMAX)) RWSUM = SUM(PBM(1:NRMAX) *DVRHO(1:NRMAX)) NF=1 WFT(NF) = RWSUM*DR*1.D-6-1.5D0*RNTSUM*DR*RKEV*1.D14 ANFAV(NF) = ANFSUM*DR/VOL ANF0(NF) = FCTR(RM(1),RM(2),RNF(1,1),RNF(2,1)) IF(ANFSUM.GT.0.D0) THEN TFAV(NF) = RWSUM/(RKEV*1.D20)/ANFSUM ELSE TFAV(NF) = 0.D0 ENDIF IF(RNF(1,1).GT.0.D0) THEN TF0(NF) = FCTR(RM(1),RM(2),PBM(1),PBM(2))/(RKEV*1.D20)/ANF0(NF) ELSE TF0(NF) = 0.D0 ENDIF NF=2 WFT(NF) = 0.D0 ANFAV(NF) = 0.D0 ANF0(NF) = 0.D0 TFAV(NF) = 0.D0 TF0(NF) = 0.D0 ELSE DO NF=1,NFM ANFSUM=0.D0 RWSUM=0.D0 DO NR=1,NRMAX ANFSUM = ANFSUM+RNF(NR,NF)*DVRHO(NR) RWSUM = RWSUM +RW (NR,NF)*DVRHO(NR) ENDDO WFT(NF) = 1.5D0*RWSUM*DR*RKEV*1.D14 ANFAV(NF) = ANFSUM*DR/VOL ANF0(NF) = FCTR(RM(1),RM(2),RNF(1,NF),RNF(2,NF)) IF(ANFSUM.GT.0.D0) THEN TFAV(NF) = RWSUM/ANFSUM ELSE TFAV(NF) = 0.D0 ENDIF IF(RNF(1,NF).GT.0.D0) THEN TF0(NF) = FCTR(RM(1),RM(2),RW(1,NF),RW(2,NF))/ANF0(NF) ELSE TF0(NF) = 0.D0 ENDIF ENDDO ENDIF ! *** Line-averaged densities *** DO NS=1,NSM ANLAV(NS)=SUM(RN(1:NRMAX,NS))*DR ENDDO ! *** Ohmic, NBI and fusion powers *** POHT = SUM(POH(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PNBT = SUM(PNB(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PNFT = SUM(PNF(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 ! *** External power typically for NBI from exp. data *** DO NS=1,NSM PEXT(NS) = SUM(PEX(1:NRMAX,NS)*DVRHO(1:NRMAX))*DR/1.D6 ENDDO ! *** RF power *** DO NS=1,NSM PRFVT(NS,1) = SUM(PRFV(1:NRMAX,NS,1)*DVRHO(1:NRMAX))*DR/1.D6 PRFVT(NS,2) = SUM(PRFV(1:NRMAX,NS,2)*DVRHO(1:NRMAX))*DR/1.D6 PRFVT(NS,3) = SUM(PRFV(1:NRMAX,NS,3)*DVRHO(1:NRMAX))*DR/1.D6 PRFT (NS ) = SUM(PRF (1:NRMAX,NS) *DVRHO(1:NRMAX))*DR/1.D6 ENDDO ! *** Total NBI power distributed on electrons and bulk ions *** PBINT = SUM(PBIN(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 DO NS=1,NSM PBCLT(NS) = SUM(PBCL(1:NRMAX,NS)*DVRHO(1:NRMAX))*DR/1.D6 ENDDO ! *** Total RF power distributed on electrons and bulk ions *** PFINT = SUM(PFIN(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 DO NS=1,NSM PFCLT(NS) = SUM(PFCL(1:NRMAX,NS)*DVRHO(1:NRMAX))*DR/1.D6 ENDDO ! *** Radiation, charge exchange and ionization losses *** PRBT = SUM(PRB(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PRCT = SUM(PRC(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PRLT = SUM(PRL(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PRSUMT= SUM(PRSUM(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PCXT = SUM(PCX(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 PIET = SUM(PIE(1:NRMAX)*DVRHO(1:NRMAX))*DR/1.D6 ! *** Current densities *** AJNBT = SUM(AJNB (1:NRMAX) *DSRHO(1:NRMAX))*DR/1.D6 AJRFVT(1) = SUM(AJRFV(1:NRMAX,1)*DSRHO(1:NRMAX))*DR/1.D6 AJRFVT(2) = SUM(AJRFV(1:NRMAX,2)*DSRHO(1:NRMAX))*DR/1.D6 AJRFVT(3) = SUM(AJRFV(1:NRMAX,3)*DSRHO(1:NRMAX))*DR/1.D6 AJRFT = SUM(AJRF (1:NRMAX) *DSRHO(1:NRMAX))*DR/1.D6 AJBST = SUM(AJBS (1:NRMAX) *DSRHO(1:NRMAX))*DR/1.D6 AJT = SUM(AJ (1:NRMAX)*DSRHO(1:NRMAX))*DR/1.D6 ! Plasma current, AJTTOR AJTTOR = SUM(AJTOR(1:NRMAX)*DSRHO(1:NRMAX))*DR/1.D6 AJOHT = SUM(AJOH (1:NRMAX)*DSRHO(1:NRMAX))*DR/1.D6 ! *** Output source and power *** ! evaluate output power using flux at NR=NRMAX IF(RHOA.EQ.1.D0) THEN NRL=NRMAX ELSE NRL=NRAMAX ENDIF NSW=3 NRMAX=NRAMAX CALL TR_COEF_DECIDE(NRL,NSW,DV53) NRMAX=NROMAX NMK=2 DRH=DR/DVRHO(NRL)**(2.D0/3.D0) C83=8.D0/3.D0 DO NEQ=1,NEQMAX NSSN=NSS(NEQ) NSVN=NSV(NEQ) SUML=0.D0 DO NW=1,NEQMAX NSSN1=NSS(NW) NSVN1=NSV(NW) IF(NSVN1.EQ.1) THEN SUML=SUML+(-DD(NEQ,NW,NMK,NSW)/3.D0)*DRH *RN(NRL-1,NSSN1) & & + DD(NEQ,NW,NMK,NSW)*3.D0 *DRH *RN(NRL ,NSSN1) & & +( VV(NEQ,NW,NMK,NSW) *DRH & & -DD(NEQ,NW,NMK,NSW)*C83 )*DRH *PNSS(NSSN1) ELSEIF(NSVN1.EQ.2) THEN SUML=SUML+(-DD(NEQ,NW,NMK,NSW)/3.D0)*DRH *RN(NRL-1,NSSN1)*RT(NRL-1,NSSN1) & & + DD(NEQ,NW,NMK,NSW)*3.D0 *DRH *RN(NRL ,NSSN1)*RT(NRL ,NSSN1) & & +( VV(NEQ,NW,NMK,NSW) *DRH & & -DD(NEQ,NW,NMK,NSW)*C83 *DRH)*PNSS(NSSN1)*PTS (NSSN1) ENDIF ENDDO IF(NSVN.EQ.1) THEN SLT(NSSN)=SUML*RKEV*1.D14 ELSEIF(NSVN.EQ.2) THEN PLT(NSSN)=SUML*RKEV*1.D14 ENDIF ENDDO ! *** Ionization, fusion and NBI fuelling *** SIET = SUM(SIE(1:NRMAX)*DVRHO(1:NRMAX))*DR SNFT = SUM(SNF(1:NRMAX)*DVRHO(1:NRMAX))*DR SNBT = SUM(SNB(1:NRMAX)*DVRHO(1:NRMAX))*DR ! *** Pellet injection fuelling *** DO NS=1,NSM SPET(NS) = SUM(SPE(1:NRMAX,NS)*DVRHO(1:NRMAX))*DR/RKAP ENDDO ! *** Input and output sources and powers *** WBULKT=SUM(WST(1:NSM)) PEXST =SUM(PEXT(1:NSM)) PRFST =SUM(PRFT(1:NSM)) PLST =SUM(PLT(1:NSM)) SLST =SUM(SLT(1:NSM)) WTAILT=SUM(WFT(1:NFM)) WPT =WBULKT+WTAILT PINT=POHT+PNBT+PRFST+PNFT+PEXST POUT=PLST+PCXT+PIET+PRBT*PRCT+PRLT SINT=SIET+SNBT SOUT=SLST ! *** Energy confinement times *** ! TAUE1: steady state ! TAUE2: transient IF(ABS(T-TPRE).LE.1.D-70) THEN WPDOT=0.D0 ELSE WPDOT=(WPT-WPPRE)/(T-TPRE) ENDIF WPPRE=WPT TPRE=T TAUE1=WPT/PINT TAUE2=WPT/(PINT-WPDOT) ! *** Inductance and one-turn voltage *** WPOL=SUM(ABVRHOG(1:NRMAX)*RDPVRHOG(1:NRMAX)**2*DVRHOG(1:NRMAX))*DR/(2.D0*RMU0) ALI=4.D0*WPOL/(RMU0*RR*(AJTTOR*1.D6)**2) VLOOP = EZOH(NRMAX)*2.D0*PI*RR ! *** Confinement scalings (TOKAMAKS 3rd p183,184) *** ! TAUE89: ITER89-P L-mode scaling ! TAUE98: IPB98(y,2) H-mode scaling with ELMs ! H98Y2: H-mode factor ! volume-averaged isotopic mass number PAI = (PA(2)*ANSAV(2)+PA(3)*ANSAV(3)+PA(4)*ANSAV(4)) /(ANSAV(2)+ANSAV(3)+ANSAV(4)) TAUE89=4.8D-2*(RIP**0.85D0) *(RR**1.2D0) *(RA**0.3D0) *(RKAP**0.5D0) & & *(ANLAV(1)**0.1D0)*(BB**0.2D0) *(PAI**0.5D0) *(PINT**(-0.5D0)) TAUE98=0.145D0*(RIP**0.93D0) *(RR**1.39D0)*(RA**0.58D0) *(RKAP**0.78D0) & & *(ANLAV(1)**0.41D0)*(BB**0.15D0)*(PAI**0.19D0)*(PINT**(-0.69D0)) H98Y2=TAUE2/TAUE98 ! *** Fusion production rate *** QF=5.D0*PNFT/(POHT+PNBT+PRFST+PEXST) ! *** Distance of q=1 surface from magnetic axis *** IF(Q0.GE.1.D0) THEN RQ1=0.D0 ELSE IF(QP(1).GT.1.D0) THEN RQ1=SQRT((1.D0-Q0)/(QP(1)-Q0))*DR GOTO 310 ENDIF DO NR=2,NRMAX IF(QP(NR).GT.1.D0) THEN RQ1=(RG(NR)-RG(NR-1))*RA*(1.D0-QP(NR-1))/(QP(NR)-QP(NR-1))+RG(NR-1)*RA GOTO 310 ENDIF ENDDO RQ1=RA 310 CONTINUE ENDIF ! *** Effective charge number at axis *** ZEFF0=(4.D0*ZEFF(1)-ZEFF(2))/3.D0 IF(RHOA.NE.1.D0) NRMAX=NRAMAX RETURN END SUBROUTINE TRGLOB ! *********************************************************** ! SAVE DATA TO DATAT FOR GRAPHICS ! *********************************************************** SUBROUTINE TRATOT USE TRCOMM, ONLY : & & AJ, AJBS, AJBST, AJNB, AJNBT, AJOH, AJOHT, AJRF, AJRFT, AJRFV, & & AJT, AJTTOR, AK, AKDW, ALI, ANC, ANF0, ANFAV, ANFE, ANLAV, & & ANS0, ANSAV, AR1RHO, AR2RHO, BB, BETA, BETA0, BETAA, BETAP, & & BETAP0, BETAPA, BP, DR, DVRHO, ER, ETA, EZOH, GVRT, GT, GVT, & & H98Y2, NGT, NRAMAX, NRMAX, NROMAX, NTM, PBCLT, PBINT, & & PCX, PCXT, PEX, PEXT, PFCLT, PFINT, PI, PIE, PIET, PINT, PLT, & & PNB, PNBT, PNF, PNFT, POH, POHT, POUT, PRF, PRFT, PRFV, PRFVT, & & PRL, PRLT, Q0, QF, QP, RA, RHOA, RIP, RKAP, RKPRHO, RM, RMJRHO, & & RMNRHO, RN, RPSI, RQ1, RR, RT, RW, S, ALPHA, SIET, SINT, SLT, & & SNBT, SNFT, SOUT, T, TAUE1, TAUE2, TAUE89, TAUE98, TF0, TFAV, & & TS0, TSAV, VLOOP, VPOL, VTOR, WBULKT, WFT, WPDOT, WPT, WST, & & WTAILT, ZEFF, ZEFF0, RKCV, PRBT, PRCT, PRSUMT IMPLICIT NONE INTEGER(4):: IERR, NR REAL(8) :: RMN, F0D REAL(8),DIMENSION(NRMAX):: DERIV, U0 REAL(8),DIMENSION(4,NRMAX):: U REAL(8) :: TRCOFS REAL(4) :: GUCLIP IF(NGT.GE.NTM) RETURN NGT=NGT+1 GT (NGT) = GUCLIP(T) ! GVT(NGT, 1) = GUCLIP(ANS0(1)) GVT(NGT, 2) = GUCLIP(ANS0(2)) GVT(NGT, 3) = GUCLIP(ANS0(3)) GVT(NGT, 4) = GUCLIP(ANS0(4)) GVT(NGT, 5) = GUCLIP(ANSAV(1)) GVT(NGT, 6) = GUCLIP(ANSAV(2)) GVT(NGT, 7) = GUCLIP(ANSAV(3)) GVT(NGT, 8) = GUCLIP(ANSAV(4)) GVT(NGT, 9) = GUCLIP(TS0(1)) GVT(NGT,10) = GUCLIP(TS0(2)) GVT(NGT,11) = GUCLIP(TS0(3)) GVT(NGT,12) = GUCLIP(TS0(4)) GVT(NGT,13) = GUCLIP(TSAV(1)) GVT(NGT,14) = GUCLIP(TSAV(2)) GVT(NGT,15) = GUCLIP(TSAV(3)) GVT(NGT,16) = GUCLIP(TSAV(4)) GVT(NGT,17) = GUCLIP(WST(1)) GVT(NGT,18) = GUCLIP(WST(2)) GVT(NGT,19) = GUCLIP(WST(3)) GVT(NGT,20) = GUCLIP(WST(4)) GVT(NGT,21) = GUCLIP(ANF0(1)) GVT(NGT,22) = GUCLIP(ANF0(2)) GVT(NGT,23) = GUCLIP(ANFAV(1)) GVT(NGT,24) = GUCLIP(ANFAV(2)) GVT(NGT,25) = GUCLIP(TF0(1)) GVT(NGT,26) = GUCLIP(TF0(2)) GVT(NGT,27) = GUCLIP(TFAV(1)) GVT(NGT,28) = GUCLIP(TFAV(2)) GVT(NGT,29) = GUCLIP(WFT(1)) GVT(NGT,30) = GUCLIP(WFT(2)) GVT(NGT,31) = GUCLIP(WBULKT) GVT(NGT,32) = GUCLIP(WTAILT) GVT(NGT,33) = GUCLIP(WPT) GVT(NGT,34) = GUCLIP(AJT) GVT(NGT,35) = GUCLIP(AJOHT) GVT(NGT,36) = GUCLIP(AJNBT) GVT(NGT,37) = GUCLIP(AJRFT) GVT(NGT,38) = GUCLIP(AJBST) GVT(NGT,39) = GUCLIP(PINT) GVT(NGT,40) = GUCLIP(POHT) GVT(NGT,41) = GUCLIP(PNBT) GVT(NGT,42) = GUCLIP(PRFT(1)) GVT(NGT,43) = GUCLIP(PRFT(2)) GVT(NGT,44) = GUCLIP(PRFT(3)) GVT(NGT,45) = GUCLIP(PRFT(4)) GVT(NGT,46) = GUCLIP(PNFT) GVT(NGT,47) = GUCLIP(PBINT) GVT(NGT,48) = GUCLIP(PBCLT(1)) GVT(NGT,49) = GUCLIP(PBCLT(2)) GVT(NGT,50) = GUCLIP(PBCLT(3)) GVT(NGT,51) = GUCLIP(PBCLT(4)) GVT(NGT,52) = GUCLIP(PFINT) GVT(NGT,53) = GUCLIP(PFCLT(1)) GVT(NGT,54) = GUCLIP(PFCLT(2)) GVT(NGT,55) = GUCLIP(PFCLT(3)) GVT(NGT,56) = GUCLIP(PFCLT(4)) GVT(NGT,57) = GUCLIP(POUT) GVT(NGT,58) = GUCLIP(PCXT) GVT(NGT,59) = GUCLIP(PIET) GVT(NGT,60) = GUCLIP(PRSUMT) GVT(NGT,61) = GUCLIP(PLT(1)) GVT(NGT,62) = GUCLIP(PLT(2)) GVT(NGT,63) = GUCLIP(PLT(3)) GVT(NGT,64) = GUCLIP(PLT(4)) GVT(NGT,65) = GUCLIP(SINT) GVT(NGT,66) = GUCLIP(SIET) GVT(NGT,67) = GUCLIP(SNBT) GVT(NGT,68) = GUCLIP(SNFT) GVT(NGT,69) = GUCLIP(SOUT) GVT(NGT,70) = GUCLIP(SLT(1)) GVT(NGT,71) = GUCLIP(SLT(2)) GVT(NGT,72) = GUCLIP(SLT(3)) GVT(NGT,73) = GUCLIP(SLT(4)) GVT(NGT,74) = GUCLIP(VLOOP) GVT(NGT,75) = GUCLIP(ALI) GVT(NGT,76) = GUCLIP(RQ1) GVT(NGT,77) = GUCLIP(Q0) GVT(NGT,78) = GUCLIP(WPDOT) GVT(NGT,79) = GUCLIP(TAUE1) GVT(NGT,80) = GUCLIP(TAUE2) GVT(NGT,81) = GUCLIP(TAUE89) GVT(NGT,82) = GUCLIP(BETAP0) GVT(NGT,83) = GUCLIP(BETAPA) GVT(NGT,84) = GUCLIP(BETA0) GVT(NGT,85) = GUCLIP(BETAA) GVT(NGT,86) = GUCLIP(ZEFF0) GVT(NGT,87) = GUCLIP(QF) GVT(NGT,88) = GUCLIP(RIP) ! GVT(NGT,89) = GUCLIP(PEXT(1)) GVT(NGT,90) = GUCLIP(PEXT(2)) GVT(NGT,91) = GUCLIP(PRFVT(1,1)) ! ECH to electron GVT(NGT,92) = GUCLIP(PRFVT(2,1)) ! ECH to ions GVT(NGT,93) = GUCLIP(PRFVT(1,2)) ! LH to electron GVT(NGT,94) = GUCLIP(PRFVT(2,2)) ! LH to ions GVT(NGT,95) = GUCLIP(PRFVT(1,3)) ! ICRH to electron GVT(NGT,96) = GUCLIP(PRFVT(2,3)) ! ICRH to ions GVT(NGT,97) = GUCLIP(RR) GVT(NGT,98) = GUCLIP(RA) GVT(NGT,99) = GUCLIP(BB) GVT(NGT,100)= GUCLIP(RKAP) GVT(NGT,101)= GUCLIP(AJTTOR) GVT(NGT,102)= GUCLIP(TAUE98) GVT(NGT,103)= GUCLIP(H98Y2) GVT(NGT,104)= GUCLIP(ANLAV(1)) GVT(NGT,105)= GUCLIP(ANLAV(2)) GVT(NGT,106)= GUCLIP(ANLAV(3)) GVT(NGT,107)= GUCLIP(ANLAV(4)) GVT(NGT,108)= GUCLIP(PRBT) GVT(NGT,109)= GUCLIP(PRCT) GVT(NGT,110)= GUCLIP(PRLT) ! *** FOR 3D *** IF(RHOA.NE.1.D0) NRMAX=NROMAX CALL SPL1D (RM,DVRHO,DERIV,U,NRMAX,0,IERR) CALL SPL1DI0(RM,U,U0,NRMAX,IERR) DO NR=1,NRMAX GVRT(NR,NGT, 1) = GUCLIP(RT(NR,1)) GVRT(NR,NGT, 2) = GUCLIP(RT(NR,2)) GVRT(NR,NGT, 3) = GUCLIP(RT(NR,3)) GVRT(NR,NGT, 4) = GUCLIP(RT(NR,4)) GVRT(NR,NGT, 5) = GUCLIP(RN(NR,1)) GVRT(NR,NGT, 6) = GUCLIP(RN(NR,2)) GVRT(NR,NGT, 7) = GUCLIP(RN(NR,3)) GVRT(NR,NGT, 8) = GUCLIP(RN(NR,4)) GVRT(NR,NGT, 9) = GUCLIP(AJ (NR)) GVRT(NR,NGT,10) = GUCLIP(AJOH(NR)) GVRT(NR,NGT,11) = GUCLIP(AJNB(NR)) GVRT(NR,NGT,12) = GUCLIP(AJRF(NR)) GVRT(NR,NGT,13) = GUCLIP(AJBS(NR)) GVRT(NR,NGT,14) = GUCLIP(POH(NR)+PNB(NR)+PNF(NR) & & +PEX(NR,1)+PEX(NR,2)+PEX(NR,3)+PEX(NR,4) & & +PRF(NR,1)+PRF(NR,2)+PRF(NR,3)+PRF(NR,4)) GVRT(NR,NGT,15) = GUCLIP(POH(NR)) GVRT(NR,NGT,16) = GUCLIP(PNB(NR)) GVRT(NR,NGT,17) = GUCLIP(PNF(NR)) GVRT(NR,NGT,18) = GUCLIP(PRF(NR,1)) GVRT(NR,NGT,19) = GUCLIP(PRF(NR,2)) GVRT(NR,NGT,20) = GUCLIP(PRF(NR,3)) GVRT(NR,NGT,21) = GUCLIP(PRF(NR,4)) GVRT(NR,NGT,22) = GUCLIP(PRL(NR)) GVRT(NR,NGT,23) = GUCLIP(PCX(NR)) GVRT(NR,NGT,24) = GUCLIP(PIE(NR)) GVRT(NR,NGT,25) = GUCLIP(PEX(NR,1)) GVRT(NR,NGT,26) = GUCLIP(PEX(NR,2)) ! IF (NR.EQ.1) THEN ! GVRT(NR,NGT,27) = GUCLIP(Q0) ! ELSE GVRT(NR,NGT,27) = GUCLIP(QP(NR)) ! ENDIF GVRT(NR,NGT,28) = GUCLIP(EZOH(NR)) GVRT(NR,NGT,29) = GUCLIP(BETA(NR)) GVRT(NR,NGT,30) = GUCLIP(BETAP(NR)) GVRT(NR,NGT,31) = GUCLIP(EZOH(NR)*2.D0*PI*RR) GVRT(NR,NGT,32) = GUCLIP(ETA(NR)) GVRT(NR,NGT,33) = GUCLIP(ZEFF(NR)) GVRT(NR,NGT,34) = GUCLIP(AK(NR,1)) GVRT(NR,NGT,35) = GUCLIP(AK(NR,2)) GVRT(NR,NGT,36) = GUCLIP(PRFV(NR,1,1)) GVRT(NR,NGT,37) = GUCLIP(PRFV(NR,1,2)) GVRT(NR,NGT,38) = GUCLIP(PRFV(NR,1,3)) GVRT(NR,NGT,39) = GUCLIP(PRFV(NR,2,1)) GVRT(NR,NGT,40) = GUCLIP(PRFV(NR,2,2)) GVRT(NR,NGT,41) = GUCLIP(PRFV(NR,2,3)) GVRT(NR,NGT,42) = GUCLIP(AJRFV(NR,1)) GVRT(NR,NGT,43) = GUCLIP(AJRFV(NR,2)) GVRT(NR,NGT,44) = GUCLIP(AJRFV(NR,3)) GVRT(NR,NGT,45) = GUCLIP(RW(NR,1)+RW(NR,2)) GVRT(NR,NGT,46) = GUCLIP(ANC(NR)+ANFE(NR)) GVRT(NR,NGT,47) = GUCLIP(BP(NR)) GVRT(NR,NGT,48) = GUCLIP(RPSI(NR)) GVRT(NR,NGT,49) = GUCLIP(RMJRHO(NR)) GVRT(NR,NGT,50) = GUCLIP(RMNRHO(NR)) RMN=(DBLE(NR)-0.5D0)*DR CALL SPL1DI(RMN,F0D,RM,U,U0,NRMAX,IERR) GVRT(NR,NGT,51) = GUCLIP(F0D) GVRT(NR,NGT,52) = GUCLIP(RKPRHO(NR)) GVRT(NR,NGT,53) = GUCLIP(1.D0) ! DELTAR GVRT(NR,NGT,54) = GUCLIP(AR1RHO(NR)) GVRT(NR,NGT,55) = GUCLIP(AR2RHO(NR)) GVRT(NR,NGT,56) = GUCLIP(AKDW(NR,1)) GVRT(NR,NGT,57) = GUCLIP(AKDW(NR,2)) GVRT(NR,NGT,58) = GUCLIP(RN(NR,1)*RT(NR,1)) GVRT(NR,NGT,59) = GUCLIP(RN(NR,2)*RT(NR,2)) GVRT(NR,NGT,60) = GUCLIP(VTOR(NR)) GVRT(NR,NGT,61) = GUCLIP(VPOL(NR)) GVRT(NR,NGT,62) = GUCLIP(S(NR)-ALPHA(NR)) GVRT(NR,NGT,63) = GUCLIP(ER(NR)) GVRT(NR,NGT,64) = GUCLIP(S(NR)) GVRT(NR,NGT,65) = GUCLIP(ALPHA(NR)) GVRT(NR,NGT,66) = GUCLIP(TRCOFS(S(NR),ALPHA(NR),RKCV(NR))) GVRT(NR,NGT,67) = GUCLIP(2.D0*PI/QP(NR)) ENDDO IF(RHOA.NE.1.D0) NRMAX=NRAMAX ! RETURN END SUBROUTINE TRATOT ! *********************************************************** ! SAVE DATA TO DATA FOR GRAPHICS ! *********************************************************** SUBROUTINE TRATOG USE TRCOMM, ONLY : AJ, AJBS, AJNB, AJOH, AJRF, AK, BP, EZOH, GTR, GVR, NGM, NGR, NRAMAX, NRMAX , NROMAX, & & PIN, POH, Q0, QP, RHOA, RN, RPSI, RT, T, VGR1 IMPLICIT NONE INTEGER(4):: NR REAL(4) :: GUCLIP IF(NGR.GE.NGM) RETURN NGR=NGR+1 GTR(NGR)=GUCLIP(T) IF(RHOA.NE.1.D0) NRMAX=NROMAX DO NR=1,NRMAX GVR(NR,NGR, 1) = GUCLIP(RN(NR,1)) GVR(NR,NGR, 2) = GUCLIP(RN(NR,2)) GVR(NR,NGR, 3) = GUCLIP(RN(NR,3)) GVR(NR,NGR, 4) = GUCLIP(RN(NR,4)) GVR(NR,NGR, 5) = GUCLIP(RT(NR,1)) GVR(NR,NGR, 6) = GUCLIP(RT(NR,2)) GVR(NR,NGR, 7) = GUCLIP(RT(NR,3)) GVR(NR,NGR, 8) = GUCLIP(RT(NR,4)) GVR(NR+1,NGR, 9) = GUCLIP(QP(NR)) GVR(NR,NGR,10) = GUCLIP(AJ(NR)*1.D-6) GVR(NR,NGR,11) = GUCLIP(EZOH(NR)) GVR(NR,NGR,12) = GUCLIP(AJOH(NR)*1.D-6) GVR(NR,NGR,13) = GUCLIP((AJNB(NR)+AJRF(NR))*1.D-6) GVR(NR,NGR,14) = GUCLIP(AJBS(NR)*1.D-6) GVR(NR,NGR,15) = GUCLIP((PIN(NR,1)+PIN(NR,2) & & +PIN(NR,3)+PIN(NR,4))*1.D-6) GVR(NR,NGR,16) = GUCLIP(POH(NR)*1.D-6) GVR(NR,NGR,17) = GUCLIP(VGR1(NR,2)) GVR(NR,NGR,18) = GUCLIP(VGR1(NR,1)) GVR(NR,NGR,19) = GUCLIP(VGR1(NR,3)) ! GVR(NR,NGR,19) = GUCLIP(VGR3(NR,1)) GVR(NR,NGR,20) = GUCLIP(AK(NR,1)) GVR(NR,NGR,21) = GUCLIP(AK(NR,2)) ! GVR(NR,NGR,17) = GUCLIP(RW(NR,1)*1.D-6*1.5D0) ! GVR(NR,NGR,18) = GUCLIP(RW(NR,2)*1.D-6*1.5D0) ! GVR(NR,NGR,19) = GUCLIP(PNB(NR)*1.D-6) ! GVR(NR,NGR,20) = GUCLIP(PNF(NR)*1.D-6) GVR(NR,NGR,22) = GUCLIP(BP(NR)) GVR(NR,NGR,23) = GUCLIP(RPSI(NR)) ENDDO GVR(1,NGR, 9) = GUCLIP(Q0) IF(RHOA.NE.1.D0) NRMAX=NRAMAX RETURN END SUBROUTINE TRATOG ! *********************************************************** ! PRINT GLOBAL QUANTITIES ! *********************************************************** SUBROUTINE TRPRNT(KID) USE TRCOMM, ONLY : & AJ, AJBST, AJNBT, AJOHT, AJRFT, AJT, ALI, ANC, ANFAV, ANFE, & ANSAV, BB, BETA0, BETAA, BETAN, BETAP0, BETAPA, DT, GTCPU1, & KFNLOG, NGR, NGT, NRMAX, NTMAX, PBCLT, PBINT, PCXT, PFCLT, & PFINT, PICTOT, PIET, PINT, PLHNPR, PLHTOT, PLT, PN, PNBT, & PNFT, POHT, POUT, PRFT, PRSUMT, Q0, QF, QP, RIPE, RIPS, RQ1, & SIET, SINT, SLT, SNBT, SNFT, SOUT, T, TAUE1, TAUE2, TAUE89, & TAUE98, TF0, TFAV, TS0, TSAV, VLOOP, VSEC, WBULKT, WFT, & WPDOT, WPT, WST, WTAILT, ZEFF, ZEFF0, AJTTOR, PRBT, PRCT, PRLT IMPLICIT NONE CHARACTER(LEN=1),INTENT(IN):: KID INTEGER(4):: I, IERR, IST, NDD, NDM, NDY, NTH1, NTM1, NTS1 REAL(4) :: GTCPU2 CHARACTER(LEN=3) :: K1, K2, K3, K4, K5, K6 CHARACTER(LEN=40):: KCOM IF(KID.EQ.'N') THEN CALL TRNLIN(-29,IST,IERR) ELSEIF(KID.EQ.'1') THEN WRITE(6,601) T,WPT,WBULKT,WTAILT,WPDOT,TAUE1,TAUE2,TAUE89,TAUE98, & & QF,BETAP0,BETAPA,BETA0,BETAA,Q0,RQ1,ZEFF0,BETAN 601 FORMAT(' ','# TIME : ',F7.3,' SEC'/ & & ' ',3X,'WPT =',1PD10.3,' WBULKT=',1PD10.3, & & ' WTAILT=',1PD10.3,' WPDOT =',1PD10.3/ & & ' ',3X,'TAUE1 =',1PD10.3,' TAUE2 =',1PD10.3, & & ' TAUE89=',1PD10.3,' TAUE98=',1PD10.3/ & & ' ',3X,'QF =',1PD10.3/ & & ' ',3X,'BETAP0=',1PD10.3,' BETAPA=',1PD10.3, & & ' BETA0 =',1PD10.3,' BETAA =',1PD10.3/ & & ' ',3X,'Q0 =',1PD10.3,' RQ1 =',1PD10.3, & & ' ZEFF0 =',1PD10.3,' BETAN =',1PD10.3) WRITE(6,602) WST(1),TS0(1),TSAV(1),ANSAV(1), & & WST(2),TS0(2),TSAV(2),ANSAV(2), & & WST(3),TS0(3),TSAV(3),ANSAV(3), & & WST(4),TS0(4),TSAV(4),ANSAV(4), & & WFT(1),TF0(1),TFAV(1),ANFAV(1), & & WFT(2),TF0(2),TFAV(2),ANFAV(2) 602 FORMAT(' ',3X,'WE =',1PD10.3,' TE0 =',1PD10.3, & & ' TEAVE =',1PD10.3,' NEAVE =',1PD10.3/ & & ' ',3X,'WD =',1PD10.3,' TD0 =',1PD10.3, & & ' TDAVE =',1PD10.3,' NDAVE =',1PD10.3/ & & ' ',3X,'WT =',1PD10.3,' TT0 =',1PD10.3, & & ' TTAVE =',1PD10.3,' NTAVE =',1PD10.3/ & & ' ',3X,'WA =',1PD10.3,' TA0 =',1PD10.3, & & ' TAAVE =',1PD10.3,' NAAVE =',1PD10.3/ & & ' ',3X,'WB =',1PD10.3,' TB0 =',1PD10.3, & & ' TBAVE =',1PD10.3,' NBAVE =',1PD10.3/ & & ' ',3X,'WF =',1PD10.3,' TF0 =',1PD10.3, & & ' TFAVE =',1PD10.3,' NFAVE =',1PD10.3) WRITE(6,603) AJT,VLOOP,ALI,VSEC, & & AJOHT,AJNBT,AJRFT,AJBST 603 FORMAT(' ',3X,'AJT =',1PD10.3,' VLOOP =',1PD10.3, & & ' ALI =',1PD10.3,' VSEC =',1PD10.3/ & & ' ',3X,'AJOHT =',1PD10.3,' AJNBT =',1PD10.3, & & ' AJRFT =',1PD10.3,' AJBST =',1PD10.3) ! WRITE(16,603) AJTTOR,VLOOP,ALI,VSEC, & ! & AJT,AJOHT,AJNBT,AJBST ! 603 FORMAT(' ',3X,'AJTTOR=',1PD10.3,' VLOOP =',1PD10.3, & ! & ' ALI =',1PD10.3,' VSEC =',1PD10.3/ & ! & ' ',3X,'AJT =',1PD10.3,' AJOHT =',1PD10.3, & ! & ' AJNBT =',1PD10.3,' AJBST =',1PD10.3) WRITE(6,604) PINT,POHT,PNBT,PNFT, & & PRFT(1),PRFT(2),PRFT(3),PRFT(4), & & PBINT,PFINT,AJ(1)*1.D-6, & & PBCLT(1),PBCLT(2),PBCLT(3),PBCLT(4), & & PFCLT(1),PFCLT(2),PFCLT(3),PFCLT(4), & & POUT,PRSUMT,PCXT,PIET, & & PLT(1),PLT(2),PLT(3),PLT(4), & PRBT,PRCT,PRLT 604 FORMAT(' ',3X,'PINT =',1PD10.3,' POHT =',1PD10.3, & & ' PNBT =',1PD10.3,' PNFTE =',1PD10.3/ & & ' ',3X,'PRFTE =',1PD10.3,' PRFTD =',1PD10.3, & & ' PRFTT =',1PD10.3,' PRFTA =',1PD10.3/ & & ' ',3X,'PBIN =',1PD10.3,' PFIN =',1PD10.3, & & ' AJ0 =',1PD10.3/ & & ' ',3X,'PBCLE =',1PD10.3,' PBCLD =',1PD10.3, & & ' PBCLT =',1PD10.3,' PBCLA =',1PD10.3/ & & ' ',3X,'PFCLE =',1PD10.3,' PFCLD =',1PD10.3, & & ' PFCLT =',1PD10.3,' PFCLA =',1PD10.3/ & & ' ',3X,'POUT =',1PD10.3,' PRSUMT=',1PD10.3, & & ' PCXT =',1PD10.3,' PIETE =',1PD10.3/ & & ' ',3X,'PLTE =',1PD10.3,' PLTD =',1PD10.3, & & ' PLTTE =',1PD10.3,' PLTA =',1PD10.3/ & & ' ',3X,'PRBT =',1PD10.3,' PRCT =',1PD10.3, & & ' PRLT =',1PD10.3) WRITE(6,605) SINT,SIET,SNBT,SNFT, & & SOUT,ZEFF(1),ANC(1),ANFE(1), & & SLT(1),SLT(2),SLT(3),SLT(4) 605 FORMAT(' ',3X,'SINT =',1PD10.3,' SIET =',1PD10.3, & & ' SNBT =',1PD10.3,' SNFT =',1PD10.3/ & & ' ',3X,'SOUT =',1PD10.3,' ZEFF0 =',1PD10.3, & & ' ANC0 =',1PD10.3,' ANFE0 =',1PD10.3/ & & ' ',3X,'SLTET =',1PD10.3,' SLTD =',1PD10.3, & & ' SLTTT =',1PD10.3,' SLTA =',1PD10.3) ENDIF IF(KID.EQ.'2') THEN WRITE(6,611) Q0,(QP(I),I=1,NRMAX) 611 FORMAT(' ','* Q PROFILE *'/ & & (' ',5F7.3,2X,5F7.3)) ENDIF IF(KID.EQ.'3') THEN CALL GUTIME(GTCPU2) WRITE(6,621) GTCPU2-GTCPU1 621 FORMAT(' ','# CPU TIME = ',F8.3,' S') RETURN ENDIF IF(KID.EQ.'4') THEN WRITE(6,631) 631 FORMAT(' ','#',12X,'FIRST',7X,'MAX',9X,'MIN',9X,'LAST') CALL TRMXMN( 1,' NE0 ') ! CALL TRMXMN( 2,' ND0 ') ! CALL TRMXMN( 3,' NT0 ') ! CALL TRMXMN( 4,' NA0 ') CALL TRMXMN( 5,' NEAV ') ! CALL TRMXMN( 6,' NDAV ') ! CALL TRMXMN( 7,' NTAV ') ! CALL TRMXMN( 8,' NAAV ') CALL TRMXMN( 9,' TE0 ') CALL TRMXMN(10,' TD0 ') CALL TRMXMN(11,' TT0 ') ! CALL TRMXMN(12,' TA0 ') CALL TRMXMN(13,' TEAV ') CALL TRMXMN(14,' TDAV ') ! CALL TRMXMN(15,' TTAV ') ! CALL TRMXMN(16,' TAAV ') ! CALL TRMXMN(17,' WE ') ! CALL TRMXMN(18,' WD ') ! CALL TRMXMN(19,' WT ') ! CALL TRMXMN(20,' WA ') ! CALL TRMXMN(21,' NB0 ') ! CALL TRMXMN(22,' NF0 ') ! CALL TRMXMN(23,' NBAV ') ! CALL TRMXMN(24,' NFAV ') ! CALL TRMXMN(25,' TB0 ') ! CALL TRMXMN(26,' TF0 ') ! CALL TRMXMN(27,' TBAV ') ! CALL TRMXMN(28,' TFAV ') CALL TRMXMN(29,' WB ') CALL TRMXMN(30,' WF ') CALL TRMXMN(31,' WBULK ') ! CALL TRMXMN(32,' WTAIL ') CALL TRMXMN(33,' WP ') ! CALL TRMXMN(34,' IP ') CALL TRMXMN(35,' IOH ') CALL TRMXMN(36,' INB ') ! CALL TRMXMN(37,' IRF ') CALL TRMXMN(38,' IBS ') ! CALL TRMXMN(39,' PIN ') CALL TRMXMN(40,' POH ') CALL TRMXMN(41,' PNB ') ! CALL TRMXMN(42,' PRFE ') ! CALL TRMXMN(43,' PRFD ') ! CALL TRMXMN(44,' PRFT ') ! CALL TRMXMN(45,' PRFA ') CALL TRMXMN(46,' PNF ') ! CALL TRMXMN(47,' PBINT') ! CALL TRMXMN(48,' PBCLE') ! CALL TRMXMN(49,' PBCLD') ! CALL TRMXMN(50,' PBCLT') ! CALL TRMXMN(51,' PBCLA') ! CALL TRMXMN(52,' PFINT') ! CALL TRMXMN(53,' PFCLE') ! CALL TRMXMN(54,' PFCLD') ! CALL TRMXMN(55,' PFCLT') ! CALL TRMXMN(56,' PFCLA') ! CALL TRMXMN(57,' POUT ') CALL TRMXMN(58,' PCX ') CALL TRMXMN(59,' PIE ') CALL TRMXMN(60,' PRL ') CALL TRMXMN(61,' PLE ') CALL TRMXMN(62,' PLD ') CALL TRMXMN(63,' PLT ') CALL TRMXMN(64,' PLA ') ! CALL TRMXMN(65,' SIN ') ! CALL TRMXMN(66,' SIE ') ! CALL TRMXMN(67,' SNB ') ! CALL TRMXMN(68,' SNF ') ! CALL TRMXMN(69,' SOUT ') ! CALL TRMXMN(70,' SLE ') ! CALL TRMXMN(71,' SLD ') ! CALL TRMXMN(72,' SLT ') ! CALL TRMXMN(73,' SLA ') CALL TRMXMN(74,' VLOOP ') CALL TRMXMN(75,' LI ') ! CALL TRMXMN(76,' RQ1 ') ! CALL TRMXMN(77,' Q0 ') ! CALL TRMXMN(78,' WPDOT ') ! CALL TRMXMN(79,' TAUE1 ') ! CALL TRMXMN(80,' TAUE2 ') ! CALL TRMXMN(81,' TAUE89') ! CALL TRMXMN(82,' BETAP0') CALL TRMXMN(83,' BETAPA') ! CALL TRMXMN(84,' BETA0 ') ! CALL TRMXMN(85,' BETAA ') ! CALL TRMXMN(86,' ZEFF0 ') CALL TRMXMN(87,' QF ') ! CALL TRMXMN(88,' IP ') CALL TRMXMN(89,' PEX ') ENDIF IF(KID.EQ.'5') THEN WRITE(6,641)NGR,NGT,DT,NTMAX 641 FORMAT(' ','# PARAMETER INFORMATION',/ & & ' ',' NGR =',I3,' NGT =',I3,/ & & ' ',' DT =',1F5.3,' NTMAX =',I3) ENDIF IF(KID.EQ.'6') THEN WRITE(6,651)T,TAUE1,TAUE2,TAUE89,PINT 651 FORMAT(' ','# TIME : ',F7.3,' SEC'/ & & ' ',3X,'TAUE1 =',1PD10.3,' TAUE2 =',1PD10.3, & & ' TAUE89=',1PD10.3,' PINT =',1PD10.3) ENDIF IF(KID.EQ.'7'.OR.KID.EQ.'8') THEN WRITE(6,671) T,WPT,TAUE1,TAUE2,TAUE89,BETAN,BETAPA,BETA0,BETAA 671 FORMAT(' ','# TIME : ',F7.3,' SEC'/ & & ' ',3X,'WPT =',1PD10.3,' TAUE1 =',1PD10.3, & & ' TAUE2 =',1PD10.3,' TAUE89=',1PD10.3/ & & ' ',3X,'BETAN =',1PD10.3,' BETAPA=',1PD10.3, & & ' BETA0 =',1PD10.3,' BETAA =',1PD10.3) WRITE(6,672) WST(1),TS0(1),TSAV(1),ANSAV(1), & & WST(2),TS0(2),TSAV(2),ANSAV(2) 672 FORMAT(' ',3X,'WE =',1PD10.3,' TE0 =',1PD10.3, & & ' TEAVE =',1PD10.3,' NEAVE =',1PD10.3/ & & ' ',3X,'WD =',1PD10.3,' TD0 =',1PD10.3, & & ' TDAVE =',1PD10.3,' NDAVE =',1PD10.3) WRITE(6,673) AJTTOR,VLOOP,ALI,Q0,AJOHT,AJNBT,AJRFT,AJBST 673 FORMAT(' ',3X,'AJTTOR=',1PD10.3,' VLOOP =',1PD10.3, & & ' ALI =',1PD10.3,' Q0 =',1PD10.3/ & & ' ',3X,'AJOHT =',1PD10.3,' AJNBT =',1PD10.3, & & ' AJRFT =',1PD10.3,' AJBST =',1PD10.3) WRITE(6,674) PINT,POHT,PNBT, & & PRFT(1)+PRFT(2)+PRFT(3)+PRFT(4),POUT,PRLT,PCXT,PIET 674 FORMAT(' ',3X,'PINT =',1PD10.3,' POHT =',1PD10.3, & & ' PNBT =',1PD10.3,' PRFT =',1PD10.3/ & & ' ',3X,'POUT =',1PD10.3,' PRLT =',1PD10.3, & & ' PCXT =',1PD10.3,' PIETE =',1PD10.3) IF(KID.EQ.'8') THEN 1600 WRITE(6,*) '## INPUT COMMENT FOR trn.data (A40)' READ(5,'(A40)',END=9000,ERR=1600) KCOM ! OPEN(16,POSITION='APPEND',FILE=KFNLOG) ! OPEN(16,ACCESS='APPEND',FILE=KFNLOG) OPEN(16,ACCESS='SEQUENTIAL',FILE=KFNLOG) CALL GUDATE(NDY,NDM,NDD,NTH1,NTM1,NTS1) WRITE(K1,'(I3)') 100+NDY WRITE(K2,'(I3)') 100+NDM WRITE(K3,'(I3)') 100+NDD WRITE(K4,'(I3)') 100+NTH1 WRITE(K5,'(I3)') 100+NTM1 WRITE(K6,'(I3)') 100+NTS1 WRITE(16,1670) K1(2:3),K2(2:3),K3(2:3),K4(2:3),K5(2:3),K6(2:3), & & KCOM, & & RIPS,RIPE,PN(1),PN(2),BB,PICTOT,PLHTOT,PLHNPR 1670 FORMAT(' '/ & & ' ','## DATE : ', & & A2,'-',A2,'-',A2,' ',A2,':',A2,':',A2,' : ',A40/ & & ' ',3X,'RIPS =',1PD10.3,' RIPE =',1PD10.3, & & ' PNE =',1PD10.3,' PNI =',1PD10.3/ & & ' ',3X,'BB =',1PD10.3,' PICTOT=',1PD10.3, & & ' PLHTOT=',1PD10.3,' PLHNPR=',1PD10.3) WRITE(16,1671) T, & & WPT,TAUE1,TAUE2,TAUE89, & & BETAN,BETAPA,BETA0,BETAA 1671 FORMAT(' ','# TIME : ',F7.3,' SEC'/ & & ' ',3X,'WPT =',1PD10.3,' TAUE =',1PD10.3, & & ' TAUED =',1PD10.3,' TAUE89=',1PD10.3/ & & ' ',3X,'BETAN =',1PD10.3,' BETAPA=',1PD10.3, & & ' BETA0 =',1PD10.3,' BETAA =',1PD10.3) WRITE(16,1672) WST(1),TS0(1),TSAV(1),ANSAV(1), & & WST(2),TS0(2),TSAV(2),ANSAV(2) 1672 FORMAT(' ',3X,'WE =',1PD10.3,' TE0 =',1PD10.3, & & ' TEAVE =',1PD10.3,' NEAVE =',1PD10.3/ & & ' ',3X,'WD =',1PD10.3,' TD0 =',1PD10.3, & & ' TDAVE =',1PD10.3,' NDAVE =',1PD10.3) WRITE(16,1673) AJTTOR,VLOOP,ALI,Q0, & & AJOHT,AJNBT,AJRFT,AJBST 1673 FORMAT(' ',3X,'AJTTOR=',1PD10.3,' VLOOP =',1PD10.3, & & ' ALI =',1PD10.3,' Q0 =',1PD10.3/ & & ' ',3X,'AJOHT =',1PD10.3,' AJNBT =',1PD10.3, & & ' AJRFT =',1PD10.3,' AJBST =',1PD10.3) WRITE(16,1674) PINT,POHT,PNBT, & & PRFT(1)+PRFT(2)+PRFT(3)+PRFT(4), & & POUT,PRLT,PCXT,PIET 1674 FORMAT(' ',3X,'PINT =',1PD10.3,' POHT =',1PD10.3, & & ' PNBT =',1PD10.3,' PRFT =',1PD10.3/ & & ' ',3X,'POUT =',1PD10.3,' PRLT =',1PD10.3, & & ' PCXT =',1PD10.3,' PIETE =',1PD10.3) CLOSE(16) ENDIF ENDIF IF(KID.EQ.'9') THEN CALL TRDATA ENDIF 9000 RETURN END SUBROUTINE TRPRNT ! *********************************************************** ! PRINT LOCAL DATA ! *********************************************************** SUBROUTINE TRDATA USE TRCOMM, ONLY : GRG, GRM, GT, GVR, GVT, NGR, NT IMPLICIT NONE INTEGER(4):: MGH, MGMAX, MGMIN, MGSTEP, MID, MRMAX, MRMIN, MRSTEP, MTMAX, MTMIN, MTSTEP, NG, NID, NR 1 WRITE(6,*) '## INPUT MODE : 1:GVT(NT) 2:GVR(NR) 3:GVR(NG)' WRITE(6,*) ' NOW NGR=',NGR READ(5,*,END=9000,ERR=1) NID IF(NID.EQ.0) GOTO 9000 IF(NID.EQ.1) THEN 10 WRITE(6,*) '## INPUT NID,NTMIN,NTMAX,NTSTEP' READ(5,*,END=1,ERR=10) MID,MTMIN,MTMAX,MTSTEP IF(MID.EQ.0) GOTO 1 DO NT=MTMIN,MTMAX,MTSTEP WRITE(6,601) NT,GT(NT),GVT(NT,MID) ENDDO GOTO 10 ELSEIF(NID.EQ.2) THEN 20 WRITE(6,*) '## INPUT NID,NG,NRMIN,NRMAX,NRSTEP,G or H(1 or 2)' READ(5,*,END=1,ERR=20) MID,NG,MRMIN,MRMAX,MRSTEP,MGH IF(MID.EQ.0) GOTO 1 DO NR=MRMIN,MRMAX,MRSTEP IF(MGH.EQ.1) THEN WRITE(6,602) NG,NR,GRG(NR+1),GVR(NR,NG,MID) ELSEIF(MGH.EQ.2) THEN WRITE(6,602) NG,NR,GRM(NR),GVR(NR,NG,MID) ELSE GOTO 1 ENDIF ENDDO GOTO 20 ELSEIF(NID.EQ.3) THEN 30 WRITE(6,*) '## INPUT NID,NR,NGMIN,NGMAX,NGSTEP,G or H(1 or 2)' READ(5,*,END=1,ERR=30) MID,NR,MGMIN,MGMAX,MGSTEP,MGH IF(MID.EQ.0) GOTO 1 DO NG=MGMIN,MGMAX,MGSTEP IF(MGH.EQ.1) THEN WRITE(6,602) NG,NR,GRG(NR+1),GVR(NR,NG,MID) ELSEIF(MGH.EQ.2) THEN WRITE(6,602) NG,NR,GRM(NR),GVR(NR,NG,MID) ELSE GOTO 1 ENDIF ENDDO GOTO 30 ENDIF GOTO 1 9000 RETURN 601 FORMAT(' ',' NT=',I3,' T=',1PE12.4,' DATA=',1PE12.4) 602 FORMAT(' ',' NG=',I3,' NR=',I3,' R=',1PE12.4, ' DATA=',1PE12.4) END SUBROUTINE TRDATA ! *********************************************************** ! PEAK-VALUE WO SAGASE ! *********************************************************** SUBROUTINE TRMXMN(N,STR) USE TRCOMM, ONLY : GVT, NGT, NT IMPLICIT NONE INTEGER(4):: N REAL(4) :: GVMAX, GVMIN CHARACTER STR*7 GVMAX=GVT(1,N) GVMIN=GVT(1,N) DO NT=2,NGT GVMAX=MAX(GVMAX,GVT(NT,N)) GVMIN=MIN(GVMIN,GVT(NT,N)) ENDDO WRITE(6,600) STR,GVT(1,N),GVMAX,GVMIN,GVT(NGT,N) 600 FORMAT(' ',A8,5X,1PD10.3,2X,1PD10.3,2X,1PD10.3,2X,1PD10.3) RETURN END SUBROUTINE TRMXMN ! *********************************************************** ! SIMPLE STATUS REPORT ! *********************************************************** SUBROUTINE TRSNAP USE TRCOMM, ONLY : Q0, RT, T, TAUE1, WPT IMPLICIT NONE WRITE(6,601) T,WPT,TAUE1,Q0,RT(1,1),RT(1,2),RT(1,3),RT(1,4) 601 FORMAT(' ','# T: ',F7.3,'(S) WP:',F7.2,'(MJ) ', & & ' TAUE:',F7.3,'(S) Q0:',F7.3,/ & & ' ',' TE:',F7.3,'(KEV) TD:',F7.3,'(KEV) ', & & ' TT:',F7.3,'(KEV) TA:',F7.3,'(KEV)') RETURN END SUBROUTINE TRSNAP ! *********************************************************** ! SAVE PROFILE DATA ! *********************************************************** SUBROUTINE TRXOUT USE TRCOMM, ONLY : MDLUF USE TRCOM2 IMPLICIT NONE INTEGER(4):: IERR, IKDIRW, IKNDCG, IKNDEV, IKNID CHARACTER(LEN=80):: KDIRW, KFID KXNDEV='X' KXNDCG='test' KXNID ='in' IKNDEV=len_trim(KXNDEV) IKNDCG=len_trim(KXNDCG) IKNID =len_trim(KXNID ) KDIRW='./profile_data/'//KXNDEV(1:IKNDEV)//'/' & & //KXNDCG(1:IKNDCG)//'/' & & //KXNID (1:IKNID )//'/' ! KDIRW='../../tr.new/data/'//KXNDEV(1:IKNDEV)//'/' & ! & //KXNDCG(1:IKNDCG)//'/' & ! & //KXNID (1:IKNID )//'/' !! KDIRW='../../../profile/profile_data/'//KXNDEV(1:IKNDEV)//'/' !! & //KXNDCG(1:IKNDCG)//'/' !! & //KXNID (1:IKNID )//'/' IKDIRW=len_trim(KDIRW) KDIRW1=KDIRW(1:IKDIRW)//KXNDEV(1:IKNDEV) & & //'1d'//KXNDCG(1:IKNDCG)//'.' KDIRW2=KDIRW(1:IKDIRW)//KXNDEV(1:IKNDEV) & & //'2d'//KXNDCG(1:IKNDCG)//'.' ! *** 1D DATA *** KFID='IP' CALL TR_UFILE1D_CREATE(KFID,34,1.D6 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 2,1.D0 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 3,1.D0 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 4,1.D0 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 5,1.D0 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 6,1.D0 ,IERR) IF(MDLUF.NE.0) THEN KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 8,1.D0 ,IERR) ELSE KFID='PNBI' CALL TR_UFILE1D_CREATE(KFID,41,1.D0 ,IERR) ENDIF KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID, 9,1.D0 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID,10,1.D0 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID,11,1.D0 ,IERR) KFID='PRAD' CALL TR_UFILE1D_CREATE(KFID,60,1.D0 ,IERR) KFID='ZEFF' CALL TR_UFILE1D_CREATE(KFID,86,1.D0 ,IERR) KFID='VSURF' CALL TR_UFILE1D_CREATE(KFID,74,1.D0 ,IERR) KFID='LI' CALL TR_UFILE1D_CREATE(KFID,75,1.D0 ,IERR) KFID='WTH' CALL TR_UFILE1D_CREATE(KFID,31,1.D6 ,IERR) KFID='WTOT' CALL TR_UFILE1D_CREATE(KFID,33,1.D6 ,IERR) KFID='TE0' CALL TR_UFILE1D_CREATE(KFID, 9,1.D3 ,IERR) KFID='TI0' CALL TR_UFILE1D_CREATE(KFID,10,1.D3 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID,26,1.D0 ,IERR) KFID='POHM' CALL TR_UFILE1D_CREATE(KFID,40,1.D0 ,IERR) KFID='IBOOT' CALL TR_UFILE1D_CREATE(KFID,38,1.D6 ,IERR) KFID='DIRECT' CALL TR_UFILE1D_CREATE(KFID,29,1.D0 ,IERR) KFID='PFUSION' CALL TR_UFILE1D_CREATE(KFID,46,1.D0 ,IERR) ! *** 2D DATA *** KFID='TE' CALL TR_UFILE2D_CREATE(KFID, 1,1.D3 ,0,IERR) KFID='TI' CALL TR_UFILE2D_CREATE(KFID, 2,1.D3 ,0,IERR) KFID='NE' CALL TR_UFILE2D_CREATE(KFID, 5,1.D20,0,IERR) IF(MDLUF.NE.0) THEN KFID='QNBIE' CALL TR_UFILE2D_CREATE(KFID,89,1.D0 ,0,IERR) ENDIF KFID='QICRHE' CALL TR_UFILE2D_CREATE(KFID,38,1.D0 ,0,IERR) KFID='QECHE' CALL TR_UFILE2D_CREATE(KFID,36,1.D0 ,0,IERR) KFID='QLHE' CALL TR_UFILE2D_CREATE(KFID,37,1.D0 ,0,IERR) IF(MDLUF.NE.0) THEN KFID='QNBII' CALL TR_UFILE2D_CREATE(KFID,90,1.D0 ,0,IERR) ENDIF KFID='QICRHI' CALL TR_UFILE2D_CREATE(KFID,41,1.D0 ,0,IERR) KFID='QECHI' CALL TR_UFILE2D_CREATE(KFID,39,1.D0 ,0,IERR) KFID='QLHI' CALL TR_UFILE2D_CREATE(KFID,40,1.D0 ,0,IERR) KFID='CURNBI' CALL TR_UFILE2D_CREATE(KFID,11,1.D0 ,0,IERR) KFID='CURICRH' CALL TR_UFILE2D_CREATE(KFID,44,1.D0 ,0,IERR) KFID='CURECH' CALL TR_UFILE2D_CREATE(KFID,42,1.D0 ,0,IERR) KFID='CURLH' CALL TR_UFILE2D_CREATE(KFID,43,1.D0 ,0,IERR) KFID='NFAST' CALL TR_UFILE2D_CREATE(KFID,45,1.D20,0,IERR) KFID='QRAD' CALL TR_UFILE2D_CREATE(KFID,22,1.D0 ,0,IERR) KFID='ZEFFR' CALL TR_UFILE2D_CREATE(KFID,33,1.D0 ,0,IERR) KFID='Q' CALL TR_UFILE2D_CREATE(KFID,27,1.D0 ,1,IERR) KFID='CHIE' CALL TR_UFILE2D_CREATE(KFID,34,1.D0 ,1,IERR) KFID='CHII' CALL TR_UFILE2D_CREATE(KFID,35,1.D0 ,1,IERR) KFID='NM1' CALL TR_UFILE2D_CREATE(KFID, 6,1.D20,0,IERR) KFID='CURTOT' CALL TR_UFILE2D_CREATE(KFID, 9,1.D0 ,0,IERR) KFID='NIMP' CALL TR_UFILE2D_CREATE(KFID,46,1.D20,0,IERR) KFID='QOHM' CALL TR_UFILE2D_CREATE(KFID,15,1.D0 ,0,IERR) KFID='BPOL' CALL TR_UFILE2D_CREATE(KFID,47,1.D0 ,1,IERR) KFID='RMAJOR' CALL TR_UFILE2D_CREATE(KFID,49,1.D0 ,0,IERR) KFID='RMINOR' CALL TR_UFILE2D_CREATE(KFID,50,1.D0 ,0,IERR) KFID='VOLUME' CALL TR_UFILE2D_CREATE(KFID,51,1.D0 ,0,IERR) KFID='KAPPAR' CALL TR_UFILE2D_CREATE(KFID,52,1.D0 ,0,IERR) KFID='DELTAR' CALL TR_UFILE2D_CREATE(KFID,53,1.D0 ,0,IERR) KFID='GRHO1' CALL TR_UFILE2D_CREATE(KFID,54,1.D0 ,0,IERR) KFID='GRHO2' CALL TR_UFILE2D_CREATE(KFID,55,1.D0 ,0,IERR) KFID='CURBS' CALL TR_UFILE2D_CREATE(KFID,13,1.D0 ,0,IERR) KFID='CHITBE' CALL TR_UFILE2D_CREATE(KFID,56,1.D0 ,1,IERR) KFID='CHITBI' CALL TR_UFILE2D_CREATE(KFID,57,1.D0 ,1,IERR) KFID='ETAR' CALL TR_UFILE2D_CREATE(KFID,32,1.D0 ,0,IERR) RETURN END SUBROUTINE TRXOUT ! ***** SUBROUTINE TR_UFILE1D_CREATE(KFID,NUM,AMP,IERR) USE TRCOMM, ONLY : BB, GVRT, GT, GVT, MDLUF, NGT, NRAMAX, NRMAX, NROMAX, NTM, RA, RG, RHOA, RKAP, RR IMPLICIT NONE CHARACTER(LEN=80),INTENT(INOUT):: KFID INTEGER(4),INTENT(IN) :: NUM REAL(8), INTENT(IN) :: AMP INTEGER(4),INTENT(OUT):: IERR INTEGER(4):: ID, NTL, NTLMAX REAL(8) :: DATOUT, DTL, FQ95, TIN REAL(4),DIMENSION(NTM) :: GTL, GF1 REAL(8),DIMENSION(NTM) :: TF, DGT, DIN, DERIV REAL(8),DIMENSION(NRMAX) :: F1, DERIVQ REAL(8),DIMENSION(4,NTM):: UOUT REAL(8),DIMENSION(4,NRMAX):: UQ95 CHARACTER(LEN=80)::KERRF REAL(4) :: GUCLIP IF(KFID.EQ.'DIRECT') THEN IF(NUM.EQ.2) THEN KFID='BT' TF(1:NGT)=BB ELSEIF(NUM.EQ.3) THEN KFID='AMIN' TF(1:NGT)=RA ELSEIF(NUM.EQ.4) THEN KFID='RGEO' TF(1:NGT)=RR ELSEIF(NUM.EQ.5) THEN KFID='KAPPA' TF(1:NGT)=RKAP ELSEIF(NUM.EQ.6) THEN KFID='DELTA' TF(1:NGT)=0.D0 ELSEIF(NUM.EQ.8) THEN KFID='PNBI' TF(1:NGT)=DBLE(GVT(1:NGT,89)+GVT(1:NGT,90)) ELSEIF(NUM.EQ.9) THEN KFID='PECH' TF(1:NGT)=DBLE(GVT(1:NGT,91)+GVT(1:NGT,92)) ELSEIF(NUM.EQ.10) THEN KFID='PICRH' TF(1:NGT)=DBLE(GVT(1:NGT,95)+GVT(1:NGT,96)) ELSEIF(NUM.EQ.11) THEN KFID='PLH' TF(1:NGT)=DBLE(GVT(1:NGT,93)+GVT(1:NGT,94)) ELSEIF(NUM.EQ.26) THEN KFID='Q95' ID=0 IF(MDLUF.NE.0.AND.NRMAX.NE.NROMAX) THEN ID=1 NRMAX=NROMAX ENDIF DO NTL=1,NGT F1(1:NRMAX)=DBLE(GVRT(1:NRMAX,NTL,27)) CALL SPL1D (RG,F1,DERIVQ,UQ95,NRMAX,0,IERR) CALL SPL1DF(0.95D0,FQ95,RG,UQ95,NRMAX,IERR) TF(NTL)=FQ95 ENDDO IF(ID.NE.0) NRMAX=NRAMAX ELSEIF(NUM.EQ.29) THEN KFID='RHOA' TF(1:NGT)=RHOA ENDIF DGT(1:NGT)=DBLE(GT(1:NGT)) DIN(1:NGT)=DBLE(TF(1:NGT)) DERIV(1:NGT)=0.D0 ELSE DGT(1:NGT)=DBLE(GT(1:NGT)) DIN(1:NGT)=DBLE(GVT(1:NGT,NUM)) DERIV(1:NGT)=0.D0 ENDIF CALL SPL1D(DGT,DIN,DERIV,UOUT,NGT,0,IERR) IF(IERR.NE.0) THEN IF(KFID.EQ.'DIRECT') THEN WRITE(6,'(A,I2,A,I2)') 'XX TRXOUT: SPL1D DIRECT(',NUM,'): IERR=',IERR ELSE WRITE(6,'(A,I2,A,I2)') 'XX TRXOUT: SPL1D GVT(',NUM,'): IERR=',IERR ENDIF ENDIF DTL=0.05D0 NTLMAX=INT((GT(NGT)-GT(1))/SNGL(DTL))+1 DO NTL=1,NTLMAX TIN=DBLE(GT(1))+DTL*DBLE(NTL-1) CALL SPL1DF(TIN,DATOUT,DGT,UOUT,NGT,IERR) WRITE(KERRF,'(A,I2,A,I2)') 'XX TRXOUT: SPL1DF GVT(',NUM,'): IERR=',IERR IF(IERR.NE.0) WRITE(6,*) KERRF GTL(NTL)=GUCLIP(TIN) GF1(NTL)=GUCLIP(DATOUT*AMP) ENDDO CALL TRXW1D(KFID,GTL,GF1,NTM,NTLMAX) RETURN END SUBROUTINE TR_UFILE1D_CREATE ! ***** SUBROUTINE TR_UFILE2D_CREATE(KFID,NUM,AMP,ID,IERR) USE TRCOMM, ONLY : GVRT, GRG, GRM, GT, NGT, NRMAX, NRMP, NTM IMPLICIT NONE CHARACTER(LEN=80),INTENT(IN) :: KFID INTEGER(4) ,INTENT(IN) :: NUM, ID REAL(8) ,INTENT(IN) :: AMP INTEGER(4) ,INTENT(OUT):: IERR INTEGER(4)::NTL, NRLMAX, NTLMAX, NRL REAL(8) ::DTL, TIN, F0, R1, R2, F1, F2, FCTR REAL(4),DIMENSION(NRMP) :: GRL REAL(4),DIMENSION(NTM) :: GTL REAL(4),DIMENSION(NRMP,NTM):: GF2 REAL(8),DIMENSION(NTM) :: DGT,DIN,DERIV REAL(8),DIMENSION(4,NTM) :: U REAL(4) :: GUCLIP DGT(1:NGT)=DBLE(GT(1:NGT)) NRLMAX=NRMAX DTL=0.05D0 NTLMAX=INT((GT(NGT)-GT(1))/SNGL(DTL))+1 IF(ID.EQ.0) THEN DO NRL=1,NRLMAX GRL(NRL)=GRM(NRL) DIN(1:NGT)=DBLE(GVRT(NRL,1:NGT,NUM)) CALL SPL1D(DGT,DIN,DERIV,U,NGT,0,IERR) IF(IERR.NE.0) WRITE(6,'(A,I2,A,I2)') 'XX TRXOUT: SPL1D GVRT(',NUM,'): IERR=',IERR ! DO NTL=1,NTLMAX TIN=DBLE(GT(1))+DTL*DBLE(NTL-1) CALL SPL1DF(TIN,F0,DGT,U,NGT,IERR) IF(IERR.NE.0) WRITE(*,'(A,I2,A,I2)') 'XX TRXOUT: SPL1DF GVRT(',NUM,'): IERR=',IERR GTL(NTL) =GUCLIP(TIN) GF2(NRL,NTL)=GUCLIP(F0*AMP) ENDDO ENDDO ELSEIF(ID.EQ.1) THEN NRLMAX=NRMAX+1 NRL=1 GRL(NRL)=GRG(NRL) IF(KFID.EQ.'Q') THEN DIN(1:NGT)=(4.D0*DBLE(GVRT(NRL,1:NGT,NUM))-DBLE(GVRT(NRL+1,1:NGT,NUM)))/3.D0 ELSEIF(KFID.EQ.'BPOL') THEN DIN(1:NGT)=0.D0 ELSE DO NTL=1,NGT R1=DBLE(GRL(NRL)) R2=DBLE(GRL(NRL+1)) F1=DBLE(GVRT(NRL ,NTL,NUM)) F2=DBLE(GVRT(NRL+1,NTL,NUM)) DIN(NTL)=FCTR(R1,R2,F1,F2) ENDDO ENDIF CALL SPL1D(DGT,DIN,DERIV,U,NGT,0,IERR) IF(IERR.NE.0) WRITE(6,'(A,I2,A,I2)') 'XX TRXOUT: SPL1D GVRT(',NUM,'): IERR=',IERR DO NTL=1,NTLMAX TIN=DBLE(GT(1))+DTL*DBLE(NTL-1) CALL SPL1DF(TIN,F0,DGT,U,NGT,IERR) IF(IERR.NE.0) WRITE(*,'(A,I2,A,I2)') 'XX TRXOUT: SPL1DF GVRT(',NUM,'): IERR=',IERR GTL(NTL) =GUCLIP(TIN) GF2(NRL,NTL)=GUCLIP(F0*AMP) ENDDO DO NRL=2,NRLMAX GRL(NRL)=GRG(NRL) DIN(1:NGT)=DBLE(GVRT(NRL-1,1:NGT,NUM)) CALL SPL1D(DGT,DIN,DERIV,U,NGT,0,IERR) IF(IERR.NE.0) WRITE(6,'(A,I2,A,I2)') 'XX TRXOUT: SPL1D GVRT(',NUM,'): IERR=',IERR DO NTL=1,NTLMAX TIN=DBLE(GT(1))+DTL*DBLE(NTL-1) CALL SPL1DF(TIN,F0,DGT,U,NGT,IERR) IF(IERR.NE.0) WRITE(*,'(A,I2,A,I2)') 'XX TRXOUT: SPL1DF GVRT(',NUM,'): IERR=',IERR GTL(NTL) =GUCLIP(TIN) GF2(NRL,NTL)=GUCLIP(F0*AMP) ENDDO ENDDO ENDIF CALL TRXW2D(KFID,GTL,GRL,GF2,NRMP,NTM,NRLMAX,NTLMAX) RETURN END SUBROUTINE TR_UFILE2D_CREATE ! ***** SUBROUTINE TRXW1D(KFID,GT,GF,NTM,NTXMAX) USE TRCOM2, ONLY : KDIRW1, KXNDCG, KXNDEV IMPLICIT NONE CHARACTER(LEN=80) ,INTENT(IN):: KFID REAL(4),DIMENSION(NTM),INTENT(IN):: GT, GF INTEGER(4) ,INTENT(IN):: NTM, NTXMAX INTEGER(4):: KL1, IST, NTX CHARACTER(LEN=9) :: CDATE CHARACTER(LEN=80):: KFILE CALL GET_DATE(CDATE) KL1=len_trim(KDIRW1) KFILE=KDIRW1(1:KL1)//KFID WRITE(6,*) '- OPEN FILE:',KFILE(1:55) OPEN(16,FILE=KFILE,IOSTAT=IST,FORM='FORMATTED',ERR=10) WRITE(16,'(1X,A8,A8,A14,A29,A9)') KXNDCG(1:8),KXNDEV(1:8), & & ' ', & & ';-SHOT #- F(X) DATA -UF1DWR- ',CDATE WRITE(16,'(1X,A10,A20,A38)') 'TR:/tasktr',' ', & & ';-SHOT DATE- UFILES ASCII FILE SYSTEM' WRITE(16,'(1X,A30,A29)') & & 'TIME SECONDS ', & & ';-INDEPENDENT VARIABLE LABEL-' WRITE(16,'(1X,A30,A27)') KFID, & & ';-DEPENDENT VARIABLE LABEL-' WRITE(16,'(1X,I1,A29,A39)') 2,' ', & & ';-PROC CODE- 0:RAW 1:AVG 2:SM. 3:AVG+SM' WRITE(16,'(1X,I11,A19,A33)') NTXMAX,' ', & & ';-# OF PTS- X, F(X) DATA FOLLOW:' WRITE(16,'(1X,1P6E13.6)') (GT(NTX),NTX=1,NTXMAX) WRITE(16,'(1X,1P6E13.6)') (GF(NTX),NTX=1,NTXMAX) WRITE(16,'(A52)') & & ';----END-OF-DATA-----------------COMMENTS:-----------' CLOSE(16) RETURN 10 WRITE(6,*) 'XX NEW FILE OPEN ERROR : IOSTAT = ',IST RETURN END SUBROUTINE TRXW1D ! ***** SUBROUTINE TRXW2D(KFID,GT,GR,GF,NRM,NTM,NRXMAX,NTXMAX) USE TRCOM2, ONLY :KDIRW2, KXNDCG, KXNDEV IMPLICIT NONE CHARACTER(LEN=80) ,INTENT(IN):: KFID REAL(4),DIMENSION(NTM) ,INTENT(IN):: GT REAL(4),DIMENSION(NRM) ,INTENT(IN):: GR REAL(4),DIMENSION(NRM,NTM),INTENT(IN):: GF INTEGER(4) ,INTENT(IN):: NRM, NTM, NRXMAX, NTXMAX INTEGER(4):: KL2,IST,NRX,NTX CHARACTER(LEN=9) :: CDATE CHARACTER(LEN=80):: KFILE CALL GET_DATE(CDATE) KL2=len_trim(KDIRW2) KFILE=KDIRW2(1:KL2)//KFID WRITE(6,*) '- OPEN FILE:',KFILE(1:55) OPEN(16,FILE=KFILE,IOSTAT=IST,FORM='FORMATTED',ERR=10) WRITE(16,'(1X,A8,A8,A14,A29,A9)') KXNDCG(1:8),KXNDEV(1:8), & & ' ', & & ';-SHOT #- F(X) DATA -UF1DWR- ',CDATE WRITE(16,'(1X,A10,A20,A38)') 'TR:/tasktr',' ', & & ';-SHOT DATE- UFILES ASCII FILE SYSTEM' WRITE(16,'(1X,A30,A32)') & & 'RHO ', & & ';-INDEPENDENT VARIABLE LABEL: X-' WRITE(16,'(1X,A30,A32)') & & 'TIME SECONDS ', & & ';-INDEPENDENT VARIABLE LABEL: Y-' WRITE(16,'(1X,A30,A27)') KFID, & & ';-DEPENDENT VARIABLE LABEL-' WRITE(16,'(1X,I1,A29,A39)') 2,' ', & & ';-PROC CODE- 0:RAW 1:AVG 2:SM. 3:AVG+SM' WRITE(16,'(1X,I11,A19,A12)') NRXMAX,' ', & & ';-# OF X PTS-:' WRITE(16,'(1X,I11,A19,A35)') NTXMAX,' ', & & ';-# OF Y PTS- X, F(X) DATA FOLLOW:' WRITE(16,'(1X,1P6E13.6)') (GR(NRX),NRX=1,NRXMAX) WRITE(16,'(1X,1P6E13.6)') (GT(NTX),NTX=1,NTXMAX) WRITE(16,'(1X,1P6E13.6)') ((GF(NRX,NTX),NRX=1,NRXMAX),NTX=1,NTXMAX) WRITE(16,'(A52)') ';----END-OF-DATA-----------------COMMENTS:-----------' CLOSE(16) RETURN 10 WRITE(6,*) 'XX NEW FILE OPEN ERROR : IOSTAT = ',IST RETURN END SUBROUTINE TRXW2D ! ***** SUBROUTINE GET_DATE(CDATE) IMPLICIT NONE CHARACTER(LEN=9),INTENT(OUT):: CDATE INTEGER(4) :: NDD, NDM, NDY, NTIH, NTIM, NTIS CHARACTER(LEN=2):: CDD, CDY CHARACTER(LEN=3):: CDM CHARACTER(LEN=3),DIMENSION(12):: CDATA = & & (/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec'/) CALL GUDATE(NDY,NDM,NDD,NTIH,NTIM,NTIS) CDM=CDATA(NDM) IF(NDD.LT.10) THEN WRITE(CDD,'(A1,I1)') ' ',NDD ELSE WRITE(CDD,'(I2)') NDD ENDIF NDY=NDY-100 IF(NDY.LT.10) THEN WRITE(CDY,'(I1,I1)') 0,NDY ELSE WRITE(CDY,'(I2)') NDY ENDIF WRITE(CDATE,'(A2,A1,A3,A1,A2)') CDD,'-',CDM,'-',CDY RETURN END SUBROUTINE GET_DATE