Forked from
4C / FORESEE
191 commits behind the upstream repository.
-
Petra Lasch-Born authoredPetra Lasch-Born authored
old_out.f 12.19 KiB
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - output routines - *!
!* Specific files written from model subroutines *!
!* *!
!* contains *!
!* OLD_OUT: Initialization of output files ("private") *!
!* OUT_ASS: file output ("private") *!
!* OUT_ALL: output for monitoring allocation *!
!* OUTTEST: test of output flags *!
!* OUTTEST_YEAR: test of output flags - yearly output *!
!* OUTTEST_DAY: test of output flags - daily output *!
!* OUTTEST_COH: test of output flags - cohort output *!
!* *!
!* Copyright (C) 1996-2018 *!
!* Potsdam Institute for Climate Impact Reserach (PIK) *!
!* Authors and contributors see AUTHOR file *!
!* This file is part of 4C and is licensed under BSD-2-Clause *!
!* See LICENSE file or under: *!
!* http://www.https://opensource.org/licenses/BSD-2-Clause *!
!* Contact: *!
!* https://gitlab.pik-potsdam.de/foresee/4C *!
!* *!
!*****************************************************************!
SUBROUTINE old_out
use data_out
use data_simul
implicit none
INTEGER help_ip
CHARACTER(100) ::filename
IF(site_nr==1) THEN
help_ip=site_nr
ELSE
help_ip=ip
END IF
! open output files & write column headers
if (time_out .gt. 0) then
if (out_flag_light .ne. 0) then
unit_light=getunit()
filename = trim(site_name(help_ip))//'_light.res'//trim(anh)
OPEN (unit_light, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_light, '(A)') 'year coh totFAPR LAI '
endif
if (flag_cohout .eq. 2) then
unit_prod = getunit()
filename = trim(site_name(help_ip))//'_prod.res'//trim(anh)
OPEN (unit_prod, file=trim(dirout)// filename, status = 'UNKNOWN')
WRITE (unit_prod, '(A)') ' year day coh PAR totFPAR LUE NPP netAss grossAss nDaysPS'
unit_allo = getunit()
filename = trim(site_name(help_ip))//'_allo.res'//trim(anh)
OPEN (unit_allo, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_allo, '(A)') ' year coh ntree NPP dbh growthrate Fnew Fmax Htnew&
& lambdaf lambdas lambdar lambdac x1 x2'
endif
endif
IF (flag_dayout .ge. 2) THEN
unit_wat = getunit()
filename = trim(site_name(help_ip))//'_water.res'//trim(anh) OPEN (unit_wat, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_wat, '(A)') ' Year Iday Temp Prec Interc Int_st Int_s I_st_s Snow Snow_sm PET TRA_DEM&
& PEV AEV_s AEV_i Percol WAtot WEtot WUtot WUtot_e&
& WUtot_r Tratree Trasveg EVA_dem GP_can AET cep_can cep_sv'
unit_soicnd = getunit()
filename = trim(site_name(help_ip))//'_Nmin.res'//trim(anh)
OPEN (unit_soicnd, file=trim(dirout)//filename, status = 'UNKNOWN')
WRITE (unit_soicnd, '(A)') ' Year Iday N_min_1 N_min_2 N_min_3 N_min_4 N_min_5 N_min_6 ... '
unit_soicna = getunit()
filename = trim(site_name(help_ip))//'_remin.res'//trim(anh)
OPEN (unit_soicna, file=trim(dirout)// filename, status = 'UNKNOWN')
WRITE (unit_soicna, '(A)') ' Year Iday remin_1 remin_2 remin_3 remin_4 remin_5 remin_6'
unit_soicnr = getunit()
filename = trim(site_name(help_ip))//'_rmin.res'//trim(anh)
OPEN (unit_soicnr, file=trim(dirout)// filename, status = 'UNKNOWN')
WRITE (unit_soicnr, '(A)') ' Year Iday rmin_t rmin_w rmin_phv'
ENDIF
END SUBROUTINE old_out
!**************************************************************
SUBROUTINE OUT_ASS(ident,PAR,NPP,totFPAR,LUE,netass,grossass,ndaysps)
USE data_simul
USE data_out
IMPLICIT NONE
REAL :: temp, dayL, PAR, netAss, grossass, maintResp, NPP, totFPAR, sapresp, coarseresp, frtresp, assi, resp, LUE, ndaysps
integer :: ident
WRITE(unit_prod, '(3I5,6E12.4,F6.1)') time_cur,iday,ident, PAR,totFPAR,LUE,NPP,netAss,grossass, ndaysps
END SUBROUTINE OUT_ASS
!**************************************************************
SUBROUTINE OUT_ALL( ident, ntree, NPP, DBH, grate, Fnew,Fmax_old,Htnew, lf,ls,lr,lc,x1,x2 )
!*** Declaration part ***!
USE data_out
USE data_simul
USE data_stand
IMPLICIT NONE
INTEGER :: ident
REAL :: ntree, NPP, DBH, lf, ls, lr, lc, x1, x2, grate,Fnew,Fmax_old,Htnew
!*** Calculation part ***!
WRITE( unit_allo, '(2I5,F8.0,12F11.4)' ) time_cur, ident, ntree, NPP, DBH,grate,Fnew,Fmax_old,Htnew, lf,ls,lr,lc,x1,x2
END SUBROUTINE out_all
!**************************************************************
SUBROUTINE outtest
use data_out
use data_simul
implicit none
integer hflag, j, i
logical testflag
character a
call outtest_year
call outtest_day
call outtest_coh
call outtest_end
END subroutine outtest
!**************************************************************
SUBROUTINE outtest_year
use data_out
use data_simul
implicit none
integer i, j
logical testflag
character a
IF (time_out > 0 ) then
if (nyvar .eq. 1) then
do i = 1,outy_n
SELECT CASE (outy(i)%kind_name)
CASE ('litter')
outy(i)%out_flag = 2
CASE ('soil')
outy(i)%out_flag = 2
CASE DEFAULT
outy(i)%out_flag = 1
end select
enddo
else
outy%out_flag = 0
do j = 1,nyvar-1
testflag = .TRUE.
do i = 1,outy_n
if (trim(outy_file(j)) .eq. trim(outy(i)%kind_name)) then
SELECT CASE (outy(i)%kind_name)
CASE ('litter')
outy(i)%out_flag = 2
CASE ('soil')
outy(i)%out_flag = 2
CASE DEFAULT
outy(i)%out_flag = 1
end select
testflag = .FALSE.
exit
endif
enddo
if (testflag .and. trim(outy_file(j)) .ne. 'end') then
print *
print *,' >>>FORESEE message: Invalid output file name: '//trim(outy_file(j))
print *
endif
enddo
endif ! nyvar
IF (year/time_out > 500) then
print *,' '
write(*,*)' Warning: Your choice of yearly output steps will create'
write(*,'(I8,A)') year/time_out, ' data records per file!'
write(*,'(A)',advance='no')' Do you really want to use this value (y/n)? ' read *,a
IF (a .eq. 'n' .or. a .eq. 'N') then
write(*,'(A)',advance='no')' New value of time distance for yearly output: '
read *, time_out
ENDIF
ENDIF
ELSE
do i = 1,outy_n
outy(i)%out_flag = 0
enddo
ENDIF ! time_out > 0
END SUBROUTINE outtest_year
!**************************************************************
SUBROUTINE outtest_day
use data_out
use data_simul
implicit none
integer i, j
logical testflag
character a
! daily output
IF (flag_dayout > 0 ) then
if (ndvar .eq. 1) then
do i = 1,outd_n
outd(i)%out_flag = 1
enddo
else
outd%out_flag = 0
do j = 1,ndvar-1
testflag = .TRUE.
do i = 1,outd_n
if (trim(outd_file(j)) .eq. trim(outd(i)%kind_name)) then
outd(i)%out_flag = 1
testflag = .FALSE.
exit
endif
enddo
if (testflag .and. trim(outd_file(j)) .ne. 'end') then
print *
print *,' >>>FORESEE message: Invalid output file name: '//trim(outd_file(j))
print *
endif
enddo
endif ! ndvar
else
do i = 1,outd_n
outd(i)%out_flag = 0
enddo
endif
END SUBROUTINE outtest_day
!**************************************************************
SUBROUTINE outtest_coh
use data_out
use data_simul
implicit none
integer i, j
logical testflag
! cohort output
SELECT CASE (flag_cohout)
CASE (0)
! flags of all daily cohort files
do i = 1,outcd_n
outcd(i)%out_flag = 0
enddo
! flags of all yearly cohort files
do i = 1,outcy_n
outcy(i)%out_flag = 0
enddo
flag_cohoutd = 0
flag_cohouty = 0
CASE (1,2)
if (ncvar .eq. 1) then
! yearly cohort output
if (time_out .gt. 0) then
do i = 1,outcy_n
select case (outcy(i)%kind_name)
case ('dtr')
outcy(i)%out_flag = 2
case ('trman')
outcy(i)%out_flag = 2
case default
outcy(i)%out_flag = 1
end select
enddo
flag_cohouty = 1
else
outcy%out_flag = 0
flag_cohouty = 0
endif
! daily cohort output
if (flag_dayout .gt. 0) then
do i = 1,outcd_n
select case (outcd(i)%kind_name)
case ('dips')
outcd(i)%out_flag = 2
case ('gsdps')
outcd(i)%out_flag = 2
case default
outcd(i)%out_flag = 1
end select
enddo
else
outcd%out_flag = 0
endif
else
outcy%out_flag = 0
outcd%out_flag = 0
flag_cohoutd = 0
flag_cohouty = 0
do j = 1,ncvar-1
testflag = .TRUE.
do i = 1,outcy_n
if (trim(outc_file(j)) .eq. trim(outcy(i)%kind_name)) then
select case (outcy(i)%kind_name)
case ('dtr')
outcy(i)%out_flag = 2
case ('trman')
outcy(i)%out_flag = 2
case default
outcy(i)%out_flag = 1
end select
testflag = .FALSE.
flag_cohouty = 1 exit
endif
enddo
if (testflag .and. flag_dayout .gt. 0) then
do i = 1,outcd_n
if (trim(outc_file(j)) .eq. trim(outcd(i)%kind_name)) then
select case (outcd(i)%kind_name)
case ('dips')
outcd(i)%out_flag = 2
case ('gsdps')
outcd(i)%out_flag = 2
case default
outcd(i)%out_flag = 1
end select
testflag = .FALSE.
flag_cohouty = 1
exit
endif
enddo
endif
if (testflag .and. trim(outd_file(j)) .ne. 'end') then
print *
print *,' >>>FORESEE message: Invalid output file name: '//trim(outd_file(j))
print *
endif
enddo
endif ! ncvar
END SELECT
if (flag_cohout .eq. 2) then
out_flag_light = 1
else
out_flag_light = 0
endif
END SUBROUTINE outtest_coh
!**************************************************************
SUBROUTINE outtest_end
use data_out
use data_simul
implicit none
integer i, j
if (flag_wpm == 1 .or. flag_wpm == 21 .or. flag_wpm == 11.or.flag_wpm== 5.or. flag_wpm == 4 .or. flag_wpm == 6) then
do i = 1,oute_n
select case (oute(i)%kind_name)
case ('wpm')
oute(i)%out_flag = 1
case ('wpm_inter')
oute(i)%out_flag = 1
end select
enddo
else if (flag_wpm == 2) then
do i = 1,oute_n
select case (oute(i)%kind_name)
case ('sea')
oute(i)%out_flag = 1
case ('sea_npv')
oute(i)%out_flag = 1
case ('sea_ms')
oute(i)%out_flag = 1
case ('sea_st')
oute(i)%out_flag = 1
end select
enddoelse if(flag_wpm.eq.3) then
do i = 1,oute_n
select case (oute(i)%kind_name)
case ('sea')
oute(i)%out_flag = 1
case ('sea_npv')
oute(i)%out_flag = 1
case ('sea_ms')
oute(i)%out_flag = 1
case ('sea_st')
oute(i)%out_flag = 1
case ('wpm')
oute(i)%out_flag = 1
case ('wpm_inter')
oute(i)%out_flag = 1
end select
enddo
else
do i = 1,oute_n
oute(i)%out_flag = 0
enddo
endif
END SUBROUTINE outtest_end