Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • foresee/4C
  • gutsch/4C
2 results
Show changes
Expand all Hide whitespace changes
Inline Side-by-side
Showing
with 2419 additions and 524 deletions
source_code/version2.2_windows/PSHPACK4.H 0 → 100644
View file @ 82df1085
/*++
Copyright 1995 - 1998 Microsoft Corporation
Module Name:
pshpack4.h
Abstract:
This file turns 4 byte packing of structures on. (That is, it disables
automatic alignment of structure fields.) An include file is needed
because various compilers do this in different ways. For Microsoft
compatible compilers, this files uses the push option to the pack pragma
so that the poppack.h include file can restore the previous packing
reliably.
The file poppack.h is the complement to this file.
--*/
#if ! (defined(lint) || defined(_lint) || defined(RC_INVOKED))
#if ( _MSC_VER >= 800 ) || defined(_PUSHPOP_SUPPORTED)
#pragma warning(disable:4103)
#if !(defined( MIDL_PASS )) || defined( __midl )
#pragma pack(push)
#endif
#pragma pack(4)
#else
#pragma pack(4)
#endif
#endif // ! (defined(lint) || defined(_lint) || defined(RC_INVOKED))
source_code/version2.2_windows/RICHEDIT.H 0 → 100644
View file @ 82df1085
This diff is collapsed.
source_code/version2.2_windows/WINDOWS.H 0 → 100644
View file @ 82df1085
/*++ BUILD Version: 0001 Increment this if a change has global effects
Copyright (c) 1985-1997, Microsoft Corporation
Module Name:
windows.h
Abstract:
Master include file for Windows applications.
Modified with WC_STATIC by F. Suckow 04.08.2011
--*/
#ifndef _WINDOWS_
#define _WINDOWS_
#ifndef WINVER
#define WINVER 0x0400
#else
#if defined(_WIN32_WINNT) && (WINVER < 0x0400) && (_WIN32_WINNT > 0x0400)
#error WINVER setting conflicts with _WIN32_WINNT setting
#endif
#endif
#ifndef WC_STATIC
#define WC_STATIC "Static"
#endif
#if(WINVER >= 0x0500)
#pragma message ("")
#pragma message ("NOTE: WINVER has been defined as 0x0500 or greater which enables")
#pragma message ("Windows NT 5.0 and Windows 98 features. When these headers were released,")
#pragma message ("Windows NT 5.0 beta 1 and Windows 98 beta 2.1 were the current versions.")
#pragma message ("")
#pragma message ("For this release when WINVER is defined as 0x0500 or greater, you can only")
#pragma message ("build beta or test applications. To build a retail application,")
#pragma message ("set WINVER to 0x0400 or visit http://www.microsoft.com/msdn/sdk")
#pragma message ("to see if retail Windows NT 5.0 or Windows 98 headers are available.")
#pragma message ("")
#pragma message ("See the SDK release notes for more information.")
#pragma message ("")
#endif
#ifndef _INC_WINDOWS
#define _INC_WINDOWS
#if defined (_MSC_VER) && (_MSC_VER >= 1020)
#pragma once
#endif
/* If defined, the following flags inhibit definition
* of the indicated items.
*
* NOGDICAPMASKS - CC_*, LC_*, PC_*, CP_*, TC_*, RC_
* NOVIRTUALKEYCODES - VK_*
* NOWINMESSAGES - WM_*, EM_*, LB_*, CB_*
* NOWINSTYLES - WS_*, CS_*, ES_*, LBS_*, SBS_*, CBS_*
* NOSYSMETRICS - SM_*
* NOMENUS - MF_*
* NOICONS - IDI_*
* NOKEYSTATES - MK_*
* NOSYSCOMMANDS - SC_*
* NORASTEROPS - Binary and Tertiary raster ops
* NOSHOWWINDOW - SW_*
* OEMRESOURCE - OEM Resource values
* NOATOM - Atom Manager routines
* NOCLIPBOARD - Clipboard routines
* NOCOLOR - Screen colors
* NOCTLMGR - Control and Dialog routines
* NODRAWTEXT - DrawText() and DT_*
* NOGDI - All GDI defines and routines
* NOKERNEL - All KERNEL defines and routines
* NOUSER - All USER defines and routines
* NONLS - All NLS defines and routines
* NOMB - MB_* and MessageBox()
* NOMEMMGR - GMEM_*, LMEM_*, GHND, LHND, associated routines
* NOMETAFILE - typedef METAFILEPICT
* NOMINMAX - Macros min(a,b) and max(a,b)
* NOMSG - typedef MSG and associated routines
* NOOPENFILE - OpenFile(), OemToAnsi, AnsiToOem, and OF_*
* NOSCROLL - SB_* and scrolling routines
* NOSERVICE - All Service Controller routines, SERVICE_ equates, etc.
* NOSOUND - Sound driver routines
* NOTEXTMETRIC - typedef TEXTMETRIC and associated routines
* NOWH - SetWindowsHook and WH_*
* NOWINOFFSETS - GWL_*, GCL_*, associated routines
* NOCOMM - COMM driver routines
* NOKANJI - Kanji support stuff.
* NOHELP - Help engine interface.
* NOPROFILER - Profiler interface.
* NODEFERWINDOWPOS - DeferWindowPos routines
* NOMCX - Modem Configuration Extensions
*/
#if defined(RC_INVOKED) && !defined(NOWINRES)
#include <winresrc.h>
#else
#if defined(RC_INVOKED)
/* Turn off a bunch of stuff to ensure that RC files compile OK. */
#define NOATOM
#define NOGDI
#define NOGDICAPMASKS
#define NOMETAFILE
#define NOMINMAX
#define NOMSG
#define NOOPENFILE
#define NORASTEROPS
#define NOSCROLL
#define NOSOUND
#define NOSYSMETRICS
#define NOTEXTMETRIC
#define NOWH
#define NOCOMM
#define NOKANJI
#define NOCRYPT
#define NOMCX
#endif
#if !defined(_68K_) && !defined(_MPPC_) && !defined(_PPC_) && !defined(_ALPHA_) && !defined(_MIPS_) && !defined(_X86_) && defined(_M_IX86)
#define _X86_
#endif
#if !defined(_68K_) && !defined(_MPPC_) && !defined(_PPC_) && !defined(_ALPHA_) && !defined(_X86_) && !defined(_MIPS_) && defined(_M_MRX000)
#define _MIPS_
#endif
#if !defined(_68K_) && !defined(_MPPC_) && !defined(_PPC_) && !defined(_ALPHA_) && !defined(_X86_) && !defined(_MIPS_) && defined(_M_ALPHA)
#define _ALPHA_
#endif
#if !defined(_68K_) && !defined(_MPPC_) && !defined(_PPC_) && !defined(_ALPHA_) && !defined(_X86_) && !defined(_MIPS_) && defined(_M_PPC)
#define _PPC_
#endif
#if !defined(_68K_) && !defined(_MPPC_) && !defined(_PPC_) && !defined(_ALPHA_) && !defined(_X86_) && !defined(_MIPS_) && defined(_M_M68K)
#define _68K_
#endif
#if !defined(_68K_) && !defined(_MPPC_) && !defined(_PPC_) && !defined(_ALPHA_) && !defined(_X86_) && !defined(_MIPS_) && defined(_M_MPPC)
#define _MPPC_
#endif
#ifndef _MAC
#if defined(_68K_) || defined(_MPPC_)
#define _MAC
#endif
#endif
#ifndef RC_INVOKED
#if ( _MSC_VER >= 800 )
#pragma warning(disable:4001)
#pragma warning(disable:4201)
#pragma warning(disable:4214)
#pragma warning(disable:4514)
#endif
#include <excpt.h>
#include <stdarg.h>
#endif /* RC_INVOKED */
#include <windef.h>
#include <winbase.h>
#include <wingdi.h>
#include <winuser.h>
#ifdef _MAC
DECLARE_HANDLE(HKEY);
typedef HKEY *PHKEY;
#endif
#if !defined(_MAC) || defined(_WIN32NLS)
#include <winnls.h>
#endif
#ifndef _MAC
#include <wincon.h>
#include <winver.h>
#endif
#if !defined(_MAC) || defined(_WIN32REG)
#include <winreg.h>
#endif
#ifndef _MAC
#include <winnetwk.h>
#endif
#ifndef WIN32_LEAN_AND_MEAN
#include <cderr.h>
#include <dde.h>
#include <ddeml.h>
#include <dlgs.h>
#ifndef _MAC
#include <lzexpand.h>
#include <mmsystem.h>
#include <nb30.h>
#include <rpc.h>
#endif
#include <shellapi.h>
#ifndef _MAC
#include <winperf.h>
#if(_WIN32_WINNT >= 0x0400)
#include <winsock2.h>
#include <mswsock.h>
#else
#include <winsock.h>
#endif /* _WIN32_WINNT >= 0x0400 */
#endif
#ifndef NOCRYPT
#include <wincrypt.h>
#endif
#ifndef NOGDI
#include <commdlg.h>
#ifndef _MAC
#include <winspool.h>
#ifdef INC_OLE1
#include <ole.h>
#else
#include <ole2.h>
#endif /* !INC_OLE1 */
#endif /* !MAC */
#endif /* !NOGDI */
#endif /* WIN32_LEAN_AND_MEAN */
#ifdef _MAC
#include <winwlm.h>
#endif
#ifdef INC_OLE2
#include <ole2.h>
#endif /* INC_OLE2 */
#ifndef _MAC
#ifndef NOSERVICE
#include <winsvc.h>
#endif
#if(WINVER >= 0x0400)
#ifndef NOMCX
#include <mcx.h>
#endif /* NOMCX */
#ifndef NOIME
#include <imm.h>
#endif
#endif /* WINVER >= 0x0400 */
#endif
#ifndef RC_INVOKED
#if ( _MSC_VER >= 800 )
#pragma warning(default:4001)
#pragma warning(default:4201)
#pragma warning(default:4214)
/* Leave 4514 disabled. It's a stupid warning anyway. */
#endif
#endif /* RC_INVOKED */
#endif /* RC_INVOKED */
#endif /* _INC_WINDOWS */
#endif /* _WINDOWS_ */
source_code/version2.2_windows/amod_soil.f
View file @ 82df1085
......@@ -121,7 +121,7 @@ module data_soil
! arrays of given root distribution (defined input)
real, allocatable, save, dimension(:) :: root_fr ! root fraction per soil layer
! dp_rfr ! depth of root fraction / cm
! yearly fine root loss after Rasse et al. 2001
integer :: rdepth_kind ! kind of calculation of root depth
real, allocatable, dimension(:) :: wat_left ! auxiliary variable for coh%watleft to determin annual sum of available water in soil layer boardering on root zone
......@@ -298,15 +298,15 @@ module data_soil_t
! Variables and parameters for soil temperature calculation
integer flag_surf ! calculation of soil surface temperature
! 0 - old version
! 1 - new ersion with explicit surface temperature
integer :: flag_surf = 0 ! calculation of soil surface temperature
! 0 - surface temperature equals temperature of first layer
! 1 - with explicit surface temperature
real temps_surf ! soil surface temperature
real hflux_surf ! soil heat flux at soil surface
real temps_surf ! soil surface temperature
real hflux_surf ! soil heat flux at soil surface
! model parameters
real :: C0 = 0.76, & ! Faltungskoeff.
real :: C0 = 0.76, & ! coefficients for calculation of surface temperature
C1 = 0.05, &
C2 = 0.3
......
source_code/version2.2_windows/day_ini.f
View file @ 82df1085
......@@ -50,11 +50,12 @@ if (hum .le. 0.) then
else if (hum .gt. 100.) then
hum = 100.
endif
if (press .gt. 0.) then
if (prs(i,j) .gt. 0.) then
press = prs(i,j)
else
press = 1013.
endif
rad = rd(i,j)
wind = wd(i,j)
if (wind .lt. 0.) wind = 0.5
......
source_code/version2.2_windows/filesave.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* FileSave *!
!* 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/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
Subroutine FileSave (file_spec, filter_spec)
! Following example of calling the Win32 API routine GetOpenFileName
use comdlg32
!use dflib ! In case QuickWin is used
implicit none
! Declare structure used to pass and receive attributes
!
type(T_OPENFILENAME) ofn
! Declare filter specification. This is a concatenation of
! pairs of null-terminated strings. The first string in each pair
! is the file type name, the second is a semicolon-separated list
! of file types for the given name. The list ends with a trailing
! null-terminated empty string.
!
character*(*) :: filter_spec
! Declare string variable to return the file specification.
! Initialize with an initial filespec, if any - null string
! otherwise
!
!character*512 :: file_spec = ""C
character*512 :: file_spec
integer status,ilen
ofn%lStructSize = SIZEOF(ofn)
ofn%hwndOwner = NULL ! For non-console applications,
! set this to the Hwnd of the
! Owner window. For QuickWin
! and Standard Graphics projects,
! use GETHWNDQQ(QWIN$FRAMEWINDOW)
!
ofn%hInstance = NULL ! For Win32 applications, you
! can set this to the appropriate
! hInstance
!
ofn%lpstrFilter = loc(filter_spec)
ofn%lpstrCustomFilter = NULL
ofn%nMaxCustFilter = 0
ofn%nFilterIndex = 1 ! Specifies initial filter value
ofn%lpstrFile = loc(file_spec)
ofn%nMaxFile = sizeof(file_spec)
ofn%nMaxFileTitle = 0
ofn%lpstrInitialDir = NULL ! Use Windows default directory
ofn%lpstrTitle = loc(""C)
ofn%Flags = OFN_PATHMUSTEXIST
ofn%lpstrDefExt = loc("txt"C)
ofn%lpfnHook = NULL
ofn%lpTemplateName = NULL
! Call GetOpenFileName and check status
!
status = GetSaveFileName(ofn)
if (status .eq. 0) then
type *,'No file name specified'
else
! Get length of file_spec by looking for trailing NUL
ilen = INDEX(file_spec,CHAR(0))
end if
end Subroutine FileSave
source_code/version2.2_windows/getopenfilename.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* FileOpen *!
!* *!
!* 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/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
Subroutine FileOpen (file_spec, filter_spec)
! Following example of calling the Win32 API routine GetOpenFileName
use comdlg32
!use dflib ! In case QuickWin is used
implicit none
! Declare structure used to pass and receive attributes
!
type(T_OPENFILENAME) ofn
! Declare filter specification. This is a concatenation of
! pairs of null-terminated strings. The first string in each pair
! is the file type name, the second is a semicolon-separated list
! of file types for the given name. The list ends with a trailing
! null-terminated empty string.
!
character*(*) :: filter_spec
! Declare string variable to return the file specification.
! Initialize with an initial filespec, if any - null string
! otherwise
character*512 :: file_spec
integer status,ilen
ofn%lStructSize = SIZEOF(ofn)
ofn%hwndOwner = NULL ! For non-console applications,
! set this to the Hwnd of the
! Owner window. For QuickWin
! and Standard Graphics projects,
! use GETHWNDQQ(QWIN$FRAMEWINDOW)
!
ofn%hInstance = NULL ! For Win32 applications, you
! can set this to the appropriate
! hInstance
!
ofn%lpstrFilter = loc(filter_spec)
ofn%lpstrCustomFilter = NULL
ofn%nMaxCustFilter = 0
ofn%nFilterIndex = 1 ! Specifies initial filter value
ofn%lpstrFile = loc(file_spec)
ofn%nMaxFile = sizeof(file_spec)
ofn%nMaxFileTitle = 0
ofn%lpstrInitialDir = NULL ! Use Windows default directory
ofn%lpstrTitle = loc(""C)
ofn%Flags = OFN_PATHMUSTEXIST
ofn%lpstrDefExt = loc("txt"C)
ofn%lpfnHook = NULL
ofn%lpTemplateName = NULL
! Call GetOpenFileName and check status
do
status = GetOpenFileName(ofn)
if (status .eq. 0) then
write(*,'(A)',advance='no') ' No file name specified'
write(*,'(A)',advance='no') ' Program aborted'
PAUSE
STOP
else
! Get length of file_spec by looking for trailing NUL
ilen = INDEX(file_spec,CHAR(0))
exit
end if
enddo
end Subroutine fileopen
source_code/version2.2_windows/initia.f
View file @ 82df1085
......@@ -118,7 +118,8 @@ SUBROUTINE INITIA
! end of declaration section
!******************************************************************************
ncl1 = 60
!ncl1 = 60
ncl1=40
allocate (zheigh(ncl1), zbhd(ncl1), zhbc(ncl1), nz(ncl1))
allocate (smaldc(ncl1), bigdc(ncl1))
print *,' '
......@@ -133,7 +134,7 @@ WRITE(*,'(A)',advance='no') ' ***Make your choice: '
READ *, data_flag
print *,' '
clwdth=2 !set diameter class-class width
clwdth=15 !set diameter class-class width
corr_la=1. !standard value for leaf area correction in stands of high sum of crown projection areas
mixed_tot_ca=0. !sum of crown projection area for mixed stands
pass = 1 !counter for number of passes through calculation loop for mixed stands
......@@ -256,7 +257,7 @@ CASE(1)
IF (datasets=='multi') THEN
select_lines=.false.
fl_num=0
if(infile=='input/hyyti_ini_0616.txt') then
ALLOCATE(ngroups(10000))
numstand= 0
......@@ -291,7 +292,6 @@ if(infile=='input/hyyti_ini_0616.txt') then
iF(baum(i).EQ.22) ngroups(nlines)%taxid=6 ! Larix
iF(baum(i).EQ.23) ngroups(nlines)%taxid=7 ! Pinus strobus
iF(baum(i).EQ.24) ngroups(nlines)%taxid=10 ! Douglasie
IF (dm(i).eq.0) dm(i) = 0.5
IF (mhoe(i).eq.0) mhoe(i) = 1.0
IF (gf(i).eq.0) gf(i) = 0.25
......@@ -310,50 +310,6 @@ if(infile=='input/hyyti_ini_0616.txt') then
3333 CONTINUE
nlines=nlines-1
WRITE(*,*) nlines,'sets of data', numstand, 'sets of stands'
ELSE
IF(select_lines) THEN
READ(listunit,*)nlines_comp
ALLOCATE(locid_comp(nlines_comp))
DO i=1,nlines_comp ! reading list of sites to be initialised
READ(listunit,*) locid_comp(i)
ENDDO ! end reading list of sites to be initialised
ENDIF ! end of reading file with sites to be selected
IF(select_lines) CLOSE(listunit)
CALL assign_DSW
CALL init_plenter_param
READ (inunit,*)nlines
ALLOCATE(ngroups(nlines))
istart=1
READ(inunit,*) ngroups(1)%locid,ngroups(1)%schicht,ngroups(1)%BRAid,ngroups(1)%alter,ngroups(1)%patchsize,ngroups(1)%mhoe,ngroups(1)%dm,ngroups(1)%volume,ngroups(1)%gf
ngroups(1)%patchsize=ngroups(1)%patchsize*10000.
ngroups(1)%baumzahl=0
ngroups(istart)%standsize=ngroups(1)%patchsize
ngroups(1)%taxid=tax_of_BRA_id(ngroups(1)%BRAid)
DO i=2,nlines
READ(inunit,*) ngroups(i)%locid,ngroups(i)%schicht,ngroups(i)%BRAid,ngroups(i)%alter,ngroups(i)%patchsize,ngroups(i)%mhoe,ngroups(i)%dm,ngroups(i)%volume,ngroups(i)%gf
WRITE(*,*) 'set no', i, 'read'
ngroups(i)%baumzahl=0
! the following line maps BRAid 770 to 779, other 'Mehlbeeren', because two
! different numbering systems existed in Brandenburg in the course of time
IF(ngroups(i)%BRAid==770) ngroups(i)%BRAid=779
ngroups(i)%patchsize=ngroups(i)%patchsize*10000.
ngroups(i)%taxid=tax_of_BRA_id(ngroups(i)%BRAid)
IF(ngroups(i)%taxid==6) ngroups(i)%taxid=3
IF(ngroups(i)%taxid==0) THEN
ELSE
ENDIF
IF(ngroups(i)%locid==ngroups(istart)%locid) THEN
ngroups(istart)%standsize=ngroups(istart)%standsize+ngroups(i)%patchsize
ngroups(i)%standsize = ngroups(istart)%standsize
ELSE
istart=i
ngroups(istart)%standsize=ngroups(i)%patchsize
fl_num=fl_num+1
ENDIF
ENDDO ! readin loop for multi data-set
ENDIF ! block for direct DSW data or brb_inv-file structure
CLOSE(inunit)
! read in file headder for description, write into ini-file
cform=1;hlp_lai=0
......@@ -571,6 +527,7 @@ if(infile=='input/hyyti_ini_0616.txt') then
! classification of single values in diameter cohorts
clwdth=1+AINT((bhdmax-bhdmin)/ncl1) !calculation of class widths
! write(4444,*) 'clwdth', clwdth, bhdmax, bhdmin, ncl1
DO i=1,ncl1
nz(i)=0
zbhd(i)=0
......@@ -771,8 +728,9 @@ CASE(6)
g=ngroups(iz)%gf !basal area/ha
gpatch=g*4. !basal area/patch
bz=ngroups(iz)%baumzahl*4. !tree numbre/patch
clwdth=dg/20.
! clwdth=dg/20.
clwdth=dg/5
! selection of uni-height curve: beech, spruce, oak calculation according to Weimann,
! other species of trees after Kuleschis (vergl. Gerold 1990)
IF (taxid==3.OR.taxid==5) THEN
......
source_code/version2.2_windows/main_4c_cons_win.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* main program for 4C *!
!* *!
!* 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/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
PROGRAM foresee
USE data_simul
real time1, time2
call CPU_time (time1)
call Act_Dir(actDir)
CALL topmenu_win
call CPU_time (time2)
print *, ' 4C total run time ', time2-time1, ' sec'
END PROGRAM foresee
source_code/version2.2_windows/pik400x.bmp 0 → 100644
View file @ 82df1085
source_code/version2.2_windows/pik400x.bmp

75.1 KiB

source_code/version2.2_windows/prepsite.f
View file @ 82df1085
......@@ -165,6 +165,7 @@ do
case (8, 9, 10)
call readsoil ! reading soil parameter
IF (flag_end .gt.0) return
call readredN ! Input redN or test resp.
end select
endif
......@@ -198,7 +199,7 @@ call readlit
! Initialization of soil model with profile data
call soil_ini ! Aufruf ohne s_cn_ini
! Initialization disturbances
IF (flag_dis .eq. 1) CALL dist_ini
IF (flag_dis .eq. 1 .or. flag_dis .eq. 2) CALL dist_ini
! Initialization of stand
call prepare_stand
IF (flag_end .gt.0) return
......@@ -268,12 +269,13 @@ if (flag_eva .gt.10) call evapo_ini
subroutine readsoil ! Input of soil parameter
use data_par
use data_soil_t
use data_site
implicit none
integer :: inunit, helpnl, helpnr
integer :: inunit, helpnl, helpnr, ihelp
real helpgrw, hlong, hlat
character :: text
character(30) :: hor, boart, helpid
......@@ -283,17 +285,15 @@ if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' readsoil'
! Setting of flag_surf from flag_cond
select case (flag_cond)
case (0,1,2,3)
flag_surf = 0
case (10,11,12,13)
flag_surf = 1
case (0,1,2,3)
flag_surf = 0
case (20,21,22,23)
flag_surf = 2
case (10,11,12,13)
flag_surf = 1
case (30,31,32,33)
flag_surf = 3
case (30,31,32,33)
flag_surf = 3
end select
! Setting of flag_bc from flag_decomp
......@@ -479,7 +479,7 @@ IF (ex .eqv. .true.) then
if (.not.flag_mult8910) print *,' >>>FORESEE message: soil_id ', soilid(ip), ' not found'
if (.not.flag_mult8910) print *,' Check your input choice!!!'
if (help==1) call dealloc_soil
CALL error_mess(time,"soil identificator not found"//adjustl(soilid(ip))//"ip No.",real(help_ip))
CALL error_mess(time,"soil identificator not found "//adjustl(soilid(ip))//"ip No.",real(help_ip))
flag_end = 5
return
ENDIF ! ios
......@@ -535,15 +535,11 @@ IF (ex .eqv. .true.) then
endif
end do
IF (ios .ne.0) then
if (.not.flag_mult8910) print *,' >>>FORESEE message: Error during reading soil data!'
WRITE(*,'(A)',advance='no') ' Stop program (y/n)? '
read *, a
IF ( a .eq. 'y' .or. a .eq. 'Y') then
print *, ' STOP program!'
stop
endif
print *,' >>>FORESEE message: Error during reading soil data!'
print *, ' Program stopped!'
IF (help==1) call dealloc_soil
if (.not.flag_mult8910) print *,' Check your input choice!!!'
flag_end = 7
return
endif ! ios
exit
endif
......@@ -556,7 +552,7 @@ IF (ex .eqv. .true.) then
print *,' Check your input choice!!!'
endif
if (help==1) call dealloc_soil
CALL error_mess(time,"soil identificator not found"//adjustl(soilid(ip))//"ip No.",real(help_ip))
CALL error_mess(time,"soil identificator not found "//adjustl(soilid(ip))//"ip No.",real(help_ip))
flag_end = 5
return
ENDIF ! ios
......@@ -915,7 +911,7 @@ if (.not.flag_mult8910 .or. (flag_mult8910 .and. anh .eq. "1") .or. (flag_mult89
WRITE(unit_ctr,'(A66,I4)') 'Time step for photosynthesis calculations (days) - ns_pro: ',ns_pro
WRITE(unit_ctr,'(A66,I4)') 'Mortality (0-OFF,1-ON stress, 2- ON stress+intr) - flag_mort: ',flag_mort
WRITE(unit_ctr,'(A66,I4)') 'Regeneration (0-OFF,1-ON, 2-weekly growth of seedl.) - flag_reg: ',flag_reg
WRITE(unit_ctr,'(A66,I4)') 'use FORSKA for regeneration (0-OFF,1-ON) - flag_forska: ',flag_forska
WRITE(unit_ctr,'(A66,I4)') 'use FORSKA for regeneration (0-OFF,1-ON) - flag_forska: ',flag_lambda
WRITE(unit_ctr,'(A66,I4)') 'Stand initialization (0-no,1-from *.ini,2-generate) - flag_stand: ',flag_stand
WRITE(unit_ctr,'(A66,I4)') 'Ground vegetation initialization (0-no,1-generate) - flag_sveg: ',flag_sveg
WRITE(unit_ctr,'(A66,I4)') 'Stand management (0-no,1-yes, 2 - seed once) - flag_mg: ',flag_mg
......@@ -1179,22 +1175,17 @@ real hNO, hNH
if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' readdepo'
if (.not.allocated(NOd)) allocate (NOd (1:366,1:year))
if (.not.allocated(NHd)) allocate (NHd (1:366, 1:year))
! for areal usage standard/constant deposition is set as concentration:
if (flag_multi .eq. 8 .or. flag_mult910) then
flag_depo = 2
if (.not.allocated(NOd)) then
allocate (NOd (1:366,1:year))
NOd = NOdep(ip) ! concentration mg/l
endif
if (.not.allocated(NHd)) then
allocate (NHd (1:366,1:year))
NHd = NHdep(ip) ! concentration mg/l
endif
NOd = NOdep(ip) ! concentration mg/l
NHd = NHdep(ip) ! concentration mg/l
return
endif
if (.not.allocated(NOd)) allocate (NOd (1:366,1:year))
if (.not.allocated(NHd)) allocate (NHd (1:366, 1:year))
NOd = 0.
NHd = 0.
......@@ -1427,6 +1418,7 @@ END subroutine readdepo
SUBROUTINE readredN
use data_out
use data_site
use data_species
use data_stand
use data_simul
......
source_code/version2.2_windows/script1.aps 0 → 100644
View file @ 82df1085
File added
source_code/version2.2_windows/script1.rc 0 → 100644
View file @ 82df1085
This diff is collapsed.
source_code/version2.2_windows/simul.f
View file @ 82df1085
......@@ -32,7 +32,6 @@ character a
character(8) actdate
character(10) acttime, helpsim, text1, text2
real time1, time2, time3
logical lhelp
unit_err=getunit()
if(flag_multi.eq.5) dirout = './'
......@@ -46,20 +45,6 @@ write (unit_trace, '(I4,I10,A)') iday, time_cur, ' sim_control'
! check daily output
if (year > 5 .and. flag_dayout .ge. 1) then
lhelp = .true.
do i = 1,outd_n
if (outd(i)%out_flag .eq. flag_dayout) then
select CASE (outd(i)%kind_name)
CASE ('day_short')
lhelp = .false.
end select
endif
enddo
if (lhelp) then
write(*,*) ' Warning: Your choice of daily output is ON with a simulation time of'
write(*,'(I6,A,I8,A)') year,' years. This option will create ',365*year,' data records per file!'
write(*,'(A)',advance='no') ' Do you really want do use daily output (y/n)? '
......@@ -67,7 +52,6 @@ if (year > 5 .and. flag_dayout .ge. 1) then
IF (a .eq. 'n' .or. a .eq. 'N') then
flag_dayout = 0
ENDIF
endif ! lhelp
ENDIF
! open file ycomp (yearly compressed output (multi run))
......@@ -136,10 +120,14 @@ time3 = 0.
case (5)
print*,ip, ' stop in readsoil, soil ID not found ', adjustl(soilid(ip))
case (6)
write(*,'(A,I5)') ' >>>foresee message: stop in read_cli - no climate data for year ',time_b
write(*,'(A,I5)') ' >>>foresee message: stop in read_cli, no climate data for year ',time_b
call finish_simul
stop
case (7)
print*,ip, ' stop in readsoil, error during reading soil data ', adjustl(soilid(ip))
call finish_simul
stop
case default
case default
print*,ip, 'flag_end = ', flag_end
end select
......@@ -228,7 +216,7 @@ if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' simulation_4C
DO time = 1, year
iday = 1
! Update population variable for new year if population is changed through interventions
if (flag_standup .gt. 0 .or. flag_dis==1) then
if (flag_standup .gt. 0 .or. flag_dis==1 .or. flag_dis==1) then
call stand_balance
call standup
flag_standup = 0
......@@ -239,7 +227,10 @@ if (flag_trace) write (unit_trace, '(I4,I10,A)') iday, time_cur, ' simulation_4C
! read or create Redn for areal application
IF (time.EQ.1 .and. flag_redn) CALL RedN_ini
IF (flag_dis .eq. 1) CALL dis_manag
IF (flag_dis .eq. 1 .or. flag_dis .eq. 2) then
CALL dis_manag
endif
! simulation of processes with subannual resolution (fluxes and soil)
CALL stand_daily
......
source_code/version2.2_windows/soil_tem.f
View file @ 82df1085
......@@ -453,12 +453,6 @@ CASE (0, 10, 20, 30, 40) ! de Vries
tcond0 = numera/denom * 86400. ! s --> day
CASE(2, 12, 22, 32, 42) ! sum like resistor; wie Widerstaende addieren
tcond2 = water%vf / water%tc + quarz%vf / quarz%tc + clay%vf / clay%tc + &
silt%vf / silt%tc + humus%vf / humus%tc + air%vf / air%tc + stone%vf / stone%tc + ice%vf / ice%tc
tcond2 = 86400. / tcond2
CASE(3, 13, 23, 33, 43) ! Campbell
vfm = clay%vf + silt%vf + stone%vf
vfs = vfm + quarz%vf + humus%vf
......@@ -504,13 +498,6 @@ CASE (1, 11, 21, 31, 41) ! Neusypina
hcapi = hcap1
tcondi = tcond1
CASE (2, 12, 22, 32, 42) ! sum like resitors; Widerstnde addieren
if ((tcond2 .gt. 8000.) .or. (tcond2 .le. 0.)) then
continue
endif
hcapi = hcap0
tcondi = tcond2
CASE (3, 13, 23, 33, 43) ! Campbell
hcapi = hcap0
tcondi = tcond3
......
source_code/version2.2_windows/sr_forska.f deleted 100755 → 0
View file @ 3a77c8a9
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Subroutines used only with flag flag_forska
!
! cetbl_4c
! CGTSPE_4c
! CLIMEF_4c
! gsdr_cal
! tmp_mean
! therm
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE CETBL_4c
use data_effect
use data_taxa
use data_simul
use data_stand
! function declarations
REAL RAND
! local variables
real :: PMX
INTEGER :: I,J,K
integer,dimension(17) :: nsap= 0
real,dimension(17) :: amdest = 0., &
amdest1 = 0.
if (flag_light.eq.1.or.flag_light.eq.2) then
PMX= Vstruct(lowest_layer)%Irel
else if (flag_light.eq.3.OR.flag_light.EQ.4) then
PMX = Bgpool(lowest_layer+1)
end if
! amend the EST for climate according to the climate multipliers
do i=1,17
AMDEST(I)=EST(I)*GDDMX(I)*DRMX(I)*TCMX(I)*TWMX(I)*PMX &
*XTFTMX(I)*TWARMX(I)
AMDEST1(I)=EST(I)*AMIN1(GDDMX(I),DRMX(I),TCMX(I),TWMX(I), &
PMX,XTFTMX(I),TWARMX(I))
IF(GSC(I).EQ.0.0)GOTO 301
301 CONTINUE
end do
RETURN
END subroutine cetbl_4c
SUBROUTINE CGTSPE_4c
! input of species data for regeneration
! reads species parameters
use data_simul
use data_taxa
! local variables
INTEGER:: I,J,K,nowunit,ntax
! reads number of taxa (NTAX)
nowunit=getunit()
open(unit=nowunit,file= '/data/safe/4C/4C_input/par/param_4c.dat', status='old')
READ(nowunit,*) NTAX
! reads for each taxon:
! NAM(I): name (8 characters)
! HMX(I): max height (m)
! HDS(I): initial slope of diameter vs height (m/cm)
! hgro(I): maximum height growth per year (m)
! ALP(I): half-saturation point (umol/m**2/s)
! LCP(I): compensation point (umol/m**2/s)
! GSC(I): growth constant (cm**2/m/yr)
! EST(I): sapling establishment rate (/ha/yr)
! TDI(I): threshold relative growth efficiency for increased mortality
! UMN(I): intrinsic mortality rate (/yr)
! UMX(I): suppressed mortality rate (/yr)
! SPR(I): number of sprouts per tree (0.0 or greater)
! SMN(I): minimum diameter for sprouting (cm)
! LAC(I): initial leaf area/D2 ratio (m**2/cm**2)
! LAF(I): sapwood turnover rate (/yr)
! BCF(I): stemwood biomass conversion factor (kg/cm**2/m)
! R(I): volumetric sapwood maintenance cost (/yr)
! Q10(I): rate of increase of respiration
! TMIN(I): minimum temperature for assimilation
! TMAX(I): maximum temperature for assimilation
! CCP(I): species compensation point
! DRI(I): maximum tolerated drought-index
!MINGDD(I): minimum growing degree-days
! MINTC(I): minimum temperature of coldest month (degrees C)
! MAXTC(I): maximum temperature of coldest month (degrees C)
! MINTW(I): minimum temperature of warmest month (degrees C)
! DORE(I): deciduous or evergreen 0=deciduous,1=evergreen
! ntc(I): nitrogen tolerance class (1,2,3,4,5)
! e1(I): Parameter smin of haadee height growth function
! e2(I): Second Parameter of haadee height growth function
! geff(I): growth efficiency factor of shaded trees
DO I=1,ntax
READ(nowunit,1) NAM(I)
READ(nowunit,*) HMX(I),HDS(I),hgro(I),ALP(I),LCP(I),GSC(I), &
EST(I),TDI(I),UMN(I),UMX(I),SPR(I),SMN(I),LAC(I),LAF(I),BCF(I), &
R(I),Q10(I),TMIN(I),TMAX(I),CCP(I),DRI(I),MINGDD(I),MINTC(I), &
MAXTC(I),MINTW(I),DORE(I),ntc(I)
IF(SPR(I).EQ.0)SMN(I)=0.0
DRI(I)=DRI(I)+0.3
end do
RETURN
! format statements
1 FORMAT(A8)
END subroutine cgtspe_4c
SUBROUTINE CLIMEF_4c
use data_taxa
use data_effect
use data_simul
! computes the growth multipliers.
! checks to see if GDD, temp coldest month below minimum for species
! if so multipliers = 0 else equals 1.
! computes drought effect multipliers as per ICP
! sets max.temp of coldest month multiplier to 0 or 1 for ESTBL routine
! checks if warmest month exceeds species limit
! averages light intensity (INS) over time step.
! local parameters
INTEGER :: I,J,K
REAL ::TOTGDD= 0, &
TGSDRT=0., &
TM4DRT=0.
real,dimension(17) :: tottft=0.
! gives growth multiplier for each species to be applied in subroutine
! TVXT or ETBL - growing degree days, growing/-4 drought index, temps.
TOTGDD=GDD(time)
TGSDRT=GSDRI(time)
TM4DRT=M4DRI(time)
! totals and then averages species specific multipliers etc. over timestep
! that is sapres, mutmx, tftmx
do i=1,17
xtftmx(i) = tftmx(i,time)
end do
! set multipliers to 1 before checking on environment
do i=1,17
GDDMX(I)=1.0
TWARMX(I)=1.0
TCMX(I)=1.0
TWMX(I)=1.0
TWARMX(I)=1.0
! check to see is a deciduous species
IF(DORE(I).EQ.0)THEN
DRMX(I)=1-((TGSDRT/DRI(I))**2)
IF(DRMX(I).LT.0.0)DRMX(I)=0.0
ELSE
! must be an evergreen
DRMX(I)=1-((TM4DRT/DRI(I))**2)
IF(DRMX(I).LT.0.0)DRMX(I)=0.0
ENDIF
! check if environment exceeds species limits - step functions
! if so set multiplier to zero
IF(TOTGDD.LT.MINGDD(I))GDDMX(I)=0.0
IF(TCOLD.LT.MINTC(I))TCMX(I)=0.0
IF(TCOLD.GT.MAXTC(I))TWMX(I)=0.0
IF(TWARM.LT.MINTW(I))TWARMX(I)=0.0
! write out to screen and forcli.out multipliers for each species
! keep these commented as they use a lot of paper <--M.B was ist damit gemeint? ist das relevant fr den nutzer.
end do
do i=1,17
end do
end subroutine climef_4c
SUBROUTINE gsdr_cal
! calculation of gsdri and m4dri for FORSKA regeneration
use data_climate
use data_effect
use data_simul
use data_evapo
if(tp(iday,time).ge.-4.) then
foudpt = foudpt + pet
foudae = foudae + aet
end if
if(tp(iday,time).ge.4.) then
tgsdpt = tgsdpt + pet
tgsdae = tgsdae + aet
end if
if(iday.eq. recs(time)) then
gsdri(time) = (tgsdpt-tgsdae)/tgsdpt
m4dri(time) = (foudpt-foudae)/foudpt
end if
END SUBROUTINE gsdr_cal
SUBROUTINE tmp_mean
! calculation of environmental variables twarm, tcold and long-term monthly
! mean of temperature
USE data_effect
USE data_climate
USE data_simul
real,dimension(12) :: tmph = 0.
integer :: i,l,m,dayc
allocate( tpmean(12))
allocate (gdd(year))
allocate (tftmx(17,year))
monrec=(/31,28,31,30,31,30,31,31,30,31,30,31/)
tpmean = 0
if (recs(time).eq.366) then
monrec(2)=29
else
monrec(2)=28
endif
do k = 1, year
! call calculation of env. variables
call therm(k)
dayc = 1
do l= 1,12
tmph(l) = 0.
do m=1,monrec(l)
tmph(l) = tmph(l) + tp( dayc,k)
dayc = dayc + 1
end do
tmph(l) = tmph(l)/monrec(l)
tpmean(l) = tpmean(l) + tmph(l)
end do
end do
do l=1,12
tpmean(l) = tpmean(l)/year
end do
! work out which is temperature of coldest month
! and warmest month for year
tcold = 50.0
twarm = -50.0
do k=1,12
if(tpmean(k).lt.tcold) tcold = tpmean(k)
if(tpmean(k).gt.twarm) twarm = tpmean(k)
end do
END SUBROUTINE tmp_mean
SUBROUTINE therm(ktime)
! therm - calculation of environmental variables (annual and species specific)
! gdd - growing degress day
! tftmx - thermal multiplier - species specific
use data_climate
use data_simul
use data_effect
use data_taxa
implicit none
! local variables
integer :: j,k,m4day,gdday1,ktime
real,dimension(17) :: tft,tresft
gdd(ktime) = 0.
m4day=0
gdday1=0
do j=1,17
tft(j)=0.0
tresft(j)=0.0
end do
! calculate ft values for each day of the year
! for each species upto number of taxa
do k=1,17
do j=1,recs(ktime)
! add up mutmx multiplier
tresft(k) = tresft(k)+(q10(k)**((tp(j,ktime) - tref)*0.1))
if(k.eq.1) then
if (tp(j,ktime).ge.tref) gdd(ktime) = gdd(ktime) + (tp(j,ktime)-tref)
end if
! first check to see if deciduous or not
if(dore(k).eq.0)then
! totalling daily deciduous multipliers for growing season only
if(tp(j,ktime).ge.5.0) then
tft(k) = tft(k)+(4*(tp(j,ktime)-tmin(k))*(tmax(k)-tp(j,ktime))/(tmin(k)-tmax(k))**2)
endif
else
! must be evergreen so produce daily values
! do not allow below zero
! checks for temperature greater than -4 oC for evergreen species
if(tp(j,ktime).ge.-4.0)then
tft(k)=tft(k)+(4*((tp(j,ktime)-tmin(k))*(tmax(k)-tp(j,ktime))) &
/(tmin(k)-tmax(k))**2)
endif
endif
if(tft(k).lt.0.0)tft(k)=0.0
end do
end do
do j=1,recs(ktime)
if(tp(j,ktime).ge.5.0) then
gdday1=gdday1+1
end if
if(tp(j,ktime).ge.-4.0) then
m4day=m4day+1
end if
end do
do k=1,17
if(dore(k).eq.0) then
tftmx(k,ktime) = tft(k)/gdday1
else
tftmx(k,ktime) = tft(k)/m4day
end if
end do
END SUBROUTINE therm
source_code/version2.2_windows/stand_bal.f
View file @ 82df1085
......@@ -104,7 +104,12 @@ do
sumbio = sumbio + ntr * zeig%coh%totBio
sumNPP = sumNPP + ntr * zeig%coh%NPP
Ndem = Ndem + ntr * zeig%coh%Ndemc_c
autresp = autresp + ntr * zeig%coh%maintres
select case (flag_dis)
case (0,1)
autresp = autresp + ntr * zeig%coh%maintres
case (2)
autresp = autresp + ntr * (zeig%coh%maintres+zeig%coh%biocost_all)
end select
totfol = totfol + ntr * zeig%coh%x_fol
totsap = totsap + ntr * zeig%coh%x_sap
totfrt = totfrt + ntr * zeig%coh%x_frt
......@@ -498,10 +503,6 @@ svar%frt = 0.
END SELECT
Enddo
IF(spar(spec_new)%phmodel==4) THEN
svar(spec_new)%daybb = svar(spec_new)%ext_daybb
ELSE
......@@ -543,7 +544,7 @@ do i=1,nspecies
svar(i)%mean_diam = svar(i)%mean_diam / ntr
svar(i)%mean_jrb = svar(i)%mean_jrb / ntr
svar(i)%basal_area = pi*ntr*(svar(i)%med_diam*svar(i)%med_diam/40000)*10000/kpatchsize
svar(i)%basal_area = pi*(ntr-helpdiam(i))*(svar(i)%med_diam*svar(i)%med_diam/40000)*10000/kpatchsize
else
svar(i)%sum_ntreea = 0.
endif
......@@ -1083,8 +1084,14 @@ IMPLICIT NONE
DO
IF(.not.associated(zeig)) exit
if (zeig%coh%species.ne.nspec_tree+2) then ! exclude mistletoe from senescence
zeig%coh%sfol = spar(zeig%coh%species)%psf * zeig%coh%x_fol
zeig%coh%sfrt = spar(zeig%coh%species)%psr * zeig%coh%x_frt
select case (flag_dis)
! case (1,2)
! zeig%coh%sfol = spar(zeig%coh%species)%psf * zeig%coh%x_fol + zeig%coh%x_fol_loss
! zeig%coh%sfrt = spar(zeig%coh%species)%psr * zeig%coh%x_frt + zeig%coh%x_frt_loss
case (0,1,2)
zeig%coh%sfol = spar(zeig%coh%species)%psf * zeig%coh%x_fol
zeig%coh%sfrt = spar(zeig%coh%species)%psr * zeig%coh%x_frt
end select
IF (zeig%coh%height.ge.thr_height .and.zeig%coh%species.LE. nspec_tree) THEN
zeig%coh%ssap = spar(zeig%coh%species)%pss * zeig%coh%x_sap
ELSE
......
source_code/version2.2_windows/win_appl.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* Subroutines for: *!
!* *!
!* - topmenu_win: calls the dialog windows *!
!* controls the application flow *!
!* *!
!* - control functions: start - ok button control *!
!* cancel - exits the application, cancel *!
!* button *!
!* stepback - back button control *!
!* *!
!* 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/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
SUBROUTINE topmenu_win
USE dflogm
INCLUDE '4C_dialogs.fd'
TYPE (DIALOG) dlg_main
integer(4) retint
call InitMain(dlg_main)
end subroutine topmenu_win
!***************************************************************
!****** Control Functions **************************************
!***************************************************************
SUBROUTINE Start ( dlg, id, callbacktype )
use dflogm
use dflib
use data_simul
use data_stand
use flag_field
implicit none
type (dialog) dlg, dlg_default_dir
integer id
integer callbacktype
integer retint
include '4C_dialogs.fd'
logical retlog, push_state
character :: text = 'Simulation control file: '
character :: text_mes = 'Measurement file: '
integer id_ctr
!Settings for FileOpen
character*(*),parameter :: filter_spec = &
"Simulation control files (*.sim)"C//"*.sim"C// &
"All Files (*)"C//"*"C//""C
character(512) filename
logical retdir
! get the radio button before the dlg was closed
retlog = DlgGet( dlg, IDC_RADIO_start, push_state )
if (push_state) id_ctr = IDC_RADIO_start
retlog = DlgGet( dlg, IDC_RADIO_edit, push_state )
if (push_state) id_ctr = IDC_RADIO_edit
! get the control file
call GetFileF (filename, filter_spec, text)
retdir = changedirqq (actdir)
simfile = filename
call readsim
call winPath
call outtest
print *, '----------------------------------'
print *, '---- Start simulation... ---------'
! simulation
call sim_control
call deallofile
if ( allocated(flagsave)) deallocate(flagsave)
print *, '4C end'
END SUBROUTINE Start
!*******************************************
SUBROUTINE Cancel ( dlg, id, callbacktype )
use dflogm
use data_simul
use data_stand
implicit none
type (dialog) dlg
integer id
integer callbacktype
integer retint
include '4C_dialogs.fd'
logical retlog, push_state
! supress compiler warnings for unreferenced arguments
integer local_id, local_callbacktype
local_id = id
local_callbacktype = callbacktype
select case(id)
case (ID_CANCEL_FLAGS)
call DlgSetReturn(dlg, ID_CANCEL_FLAGS)
call DlgExit(dlg)
case (ID_CANCEL_FILES)
call DlgSetReturn(dlg, ID_CANCEL_FILES)
call DlgExit(dlg)
case (ID_CANCEL_IDS)
call DlgSetReturn(dlg, ID_CANCEL_IDS)
call DlgExit(dlg)
case (ID_CANCEL_OUTF)
call DLGSetReturn(dlg ,ID_CANCEL_OUTF)
call DlgExit(dlg)
case (IDCANCEL)
call DLGSetReturn(dlg ,IDCANCEL)
call DlgExit(dlg)
case (IDSTOP)
print *, ''
print *, '---------------------------------------------'
stop ' -------Program terminated by the user.------'
end select
END SUBROUTINE Cancel
source_code/version2.2_windows/win_appl_dlg_init.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* Subroutines for: *!
!* - windows shell - *!
!* *!
!* contains: *!
!* InitMain *!
!* *!
!* 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/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
SUBROUTINE InitMain(dlgParent)
use dflogm
use data_simul
type (dialog) dlg
type (dialog) dlgParent
type (dialog) local_dlg
external Start, Cancel
include '4C_dialogs.fd'
logical retlog
character(150) dir
integer nflag
character(90), dimension(5) :: charflag
character(20) text, helpsim
local_dlg = dlgParent
if ( .not. DlgInit( idd_4C_main, dlg ) ) then
write (*,*) "error: resource not found"
else
! set functionality of the OK and CANCEL button
retlog = DlgSetSub( dlg, IDSTOP, Cancel )
retlog = DlgSetSub( dlg, ID_START_4C, Start )
endif
retint = DlgModal(dlg)
END SUBROUTINE InitMain
source_code/version2.2_windows/win_appl_flags_field.f90 0 → 100644
View file @ 82df1085
!*****************************************************************!
!* *!
!* 4C (FORESEE) Simulation Model *!
!* *!
!* Subroutines for: *!
!* *!
!* - data_general_dlg: module to store the general dlg info *!
!* - flag_field : module to store the flags *!
!* - flags_comments: module to store the flags commens *!
!* *!
!* *!
!* 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/XXXXXXXXXXXXXXXXXXXXX *!
!* *!
!*****************************************************************!
module data_general_dlg
! which way was chosen
integer :: id_ctr
end module
!***********************************************************************
! data module containig the flags changes for the win_appl
module flag_field
integer,allocatable,save,dimension(:,:) :: flagsave
character(50), dimension(22) :: flagnames
integer act_run
end ! module flags_field
!**********************
!contains all flag comments for the combo-boxes
module flags_comments
character(60), dimension(30) :: flag_mort_com
character(60), dimension(30) :: flag_reg_com
character(60), dimension(30) :: flag_forska_com
character(60), dimension(30) :: flag_stand_com
character(60), dimension(30) :: flag_sveg_com
character(60), dimension(30) :: flag_mg_com
character(60), dimension(30) :: flag_dis_com
character(60), dimension(30) :: flag_light_com
character(60), dimension(30) :: flag_folhei_com
character(60), dimension(30) :: flag_volfunc_com
character(60), dimension(30) :: flag_resp_com
character(60), dimension(30) :: flag_limi_com
character(60), dimension(30) :: flag_decomp_com
character(60), dimension(30) :: flag_sign_com
character(60), dimension(30) :: flag_wred_com
character(60), dimension(30) :: flag_wurz_com
character(60), dimension(30) :: flag_cond_com
character(60), dimension(30) :: flag_int_com
character(60), dimension(30) :: flag_eva_com
character(100), dimension(30) :: flag_CO2_com
character(60), dimension(30) :: flag_sort_com
character(60), dimension(30) :: flag_wpm_com
character(60), dimension(30) :: flag_stat_com
end