!============================================================================== ! This source code is part of the ! Australian Community Atmosphere Biosphere Land Exchange (CABLE) model. ! This work is licensed under the CSIRO Open Source Software License ! Agreement (variation of the BSD / MIT License). ! ! You may not use this file except in compliance with this License. ! A copy of the License (CSIRO_BSD_MIT_License_v2.0_CABLE.txt) is located ! in each directory containing CABLE code. ! ! ============================================================================== ! Purpose: Offline driver for mpi worker in CABLE global run ! ! Contact: Bernard.Pak@csiro.au ! ! History: Since 1.4b, capability to run global offline (ncciy = YEAR), ! inclusion of call to CASA-CNP (icycle>0) ! soil_snow_type now ssnow (instead of ssoil) ! ! MPI wrapper developed by Maciej Golebiewski (2012) ! Modified from cable_serial.F90 in CABLE-2.0_beta r171 by B Pak ! ! ============================================================================== ! Uses: mpi ! cable_mpicommon ! cable_def_types_mod ! cable_IO_vars_module ! cable_common_module ! cable_data_module ! cable_input_module ! cable_output_module ! cable_cbm_module ! casadimension ! casavariable ! phenvariable ! casa_cable ! casa_inout_module ! ! CALLs: ! casa_feedback ! cbm ! bgcdriver ! sumcflux ! find_extents ! worker_decomp ! worker_cable_params ! worker_casa_params ! worker_intype ! worker_outtype ! worker_casa_type ! worker_restart_type ! worker_end ! ! input file: [SiteName].nc ! poolcnpIn[SiteName].csv -- for CASA-CNP only ! gridinfo_CSIRO_1x1.nc ! def_veg_params.txt ! def_soil_params.txt -- nearly redundant, can be switched on ! restart_in.nc -- not strictly required ! ! output file: log_cable.txt ! out_cable.nc ! restart_out.nc ! poolcnpOut.csv -- from CASA-CNP !============================================================================== MODULE cable_mpiworker USE cable_driver_common_mod, ONLY : & vegparmnew, & spinup, & spincasa, & CASAONLY, & l_laiFeedbk, & l_vcmaxFeedbk, & delsoilM, & delsoilT, & LALLOC USE cable_mpicommon USE cable_common_module, ONLY: cable_user USE casa_inout_module USE casa_cable USE bgcdriver_mod, ONLY : bgcdriver IMPLICIT NONE SAVE PRIVATE ! MPI: MPI derived datatype for receiving input from the master INTEGER :: inp_t ! MPI: MPI derived datatype for sending results back to the master INTEGER :: send_t ! worker's struct for sending final casa results to the master INTEGER :: casa_t ! worker's struct for rec'ing/sending final casa results to/from the master INTEGER :: casa_dump_t ! worker's struct for rec'ing/sending casa pools to/from the master (for LUC calcs) INTEGER :: casa_LUC_t ! worker's struct for rec'ing/sending final casa results to/from the master INTEGER :: climate_t ! worker's struct for rec'ing/sending pop io to/from the master INTEGER :: pop_t ! worker's struct for restart data to the master INTEGER :: restart_t ! worker's logfile unit !INTEGER :: logn !debug moved to iovars -- easy to pass around PUBLIC :: mpidrv_worker REAL, allocatable :: heat_cap_lower_limit(:,:) CONTAINS SUBROUTINE mpidrv_worker (comm) USE mpi USE cable_def_types_mod USE cable_IO_vars_module, ONLY: logn,leaps, & output,check,& patch_type,& NO_CHECK USE cable_common_module, ONLY: ktau_gl, kend_gl, knode_gl, cable_user, & cable_runtime, filename, & CurYear, & IS_LEAPYEAR, calcsoilalbedo, & kwidth_gl USE cable_checks_module, ONLY: constant_check_range USE casa_ncdf_module, ONLY: is_casa_time USE cable_input_module, ONLY: open_met_file,load_parameters, & get_met_data,close_met_file USE cable_output_module, ONLY: create_restart,open_output_file, & write_output,close_output_file USE cable_cbm_module USE cable_climate_mod ! modules related to CASA-CNP USE casadimension, ONLY: icycle USE casavariable, ONLY: casafile, casa_biome, casa_pool, casa_flux, & casa_met, casa_balance USE phenvariable, ONLY: phen_variable !CLN added ! modules related to POP USE POPmodule, ONLY: POP_INIT USE POP_Types, ONLY: POP_TYPE USE POP_Constants, ONLY: HEIGHT_BINS, NCOHORT_MAX USE cbl_soil_snow_init_special_module IMPLICIT NONE ! MPI: INTEGER :: comm ! MPI communicator for comms with the workers ! timing variables INTEGER, PARAMETER :: kstart = 1 ! start of simulation INTEGER, PARAMETER :: mloop = 30 ! CASA-CNP PreSpinup loops INTEGER :: & ktau, & ! increment equates to timestep, resets if spinning up ktau_tot = 0, & ! NO reset when spinning up, total timesteps by model kend, & ! no. of time steps in run !CLN kstart = 1, & ! timestep to start at koffset = 0, & ! timestep to start at ktauday, & ! day counter for CASA-CNP idoy, & ! day of year (1:365) counter for CASA-CNP nyear, & ! year counter for CASA-CNP YYYY, & ! LOY, & ! Length of Year rank ! Rank of this worker REAL :: dels ! time step size in seconds ! CABLE variables TYPE (met_type) :: met ! met input variables TYPE (air_type) :: air ! air property variables TYPE (canopy_type) :: canopy ! vegetation variables TYPE (radiation_type) :: rad ! radiation variables TYPE (roughness_type) :: rough ! roughness varibles TYPE (balances_type) :: bal ! energy and water balance variables TYPE (soil_snow_type) :: ssnow ! soil and snow variables TYPE (climate_type) :: climate ! climate variables ! CABLE parameters TYPE (soil_parameter_type) :: soil ! soil parameters TYPE (veg_parameter_type) :: veg ! vegetation parameters TYPE (sum_flux_type) :: sum_flux ! cumulative flux variables TYPE (bgc_pool_type) :: bgc ! carbon pool variables ! CASA-CNP variables TYPE (casa_biome) :: casabiome TYPE (casa_pool) :: casapool TYPE (casa_flux) :: casaflux TYPE (casa_met) :: casamet TYPE (casa_balance) :: casabal TYPE (phen_variable) :: phen TYPE (POP_TYPE) :: POP LOGICAL, SAVE :: & spinConv = .FALSE., & ! has spinup converged? CALL1 = .TRUE. ! MPI: LOGICAL :: loop_exit ! MPI: exit flag for bcast to workers INTEGER :: stat(MPI_STATUS_SIZE) INTEGER :: icomm ! separate dupes of MPI communicator for send and recv INTEGER :: ocomm ! separate dupes of MPI communicator for send and recv INTEGER :: ierr !For consistency w JAC REAL,ALLOCATABLE, SAVE :: c1(:,:) REAL,ALLOCATABLE, SAVE :: rhoch(:,:) REAL,ALLOCATABLE, SAVE :: xk(:,:) ! END header ! Maciej: make sure the variable does not go out of scope mp = 0 ! Check for gswp run ! MPI: done by the master only; if check fails then master MPI_Aborts ! everyone !IF (ncciy /= 0) THEN ! ! PRINT *, 'Looking for global offline run info.' ! ! IF (ncciy < 1986 .OR. ncciy > 1995) THEN ! PRINT *, 'Year ', ncciy, ' outside range of dataset!' ! STOP 'Please check input in namelist file.' ! ELSE ! ! CALL prepareFiles(ncciy) ! ! ENDIF ! !ENDIF ! Open met data and get site information from netcdf file. ! This retrieves time step size, number of timesteps, starting date, ! latitudes, longitudes, number of sites. ! MPI: master only; necessary info will be received by MPI below !CALL open_met_file( dels, kend, spinup, C%TFRZ ) ! Checks where parameters and initialisations should be loaded from. ! If they can be found in either the met file or restart file, they will ! load from there, with the met file taking precedence. Otherwise, they'll ! be chosen from a coarse global grid of veg and soil types, based on ! the lat/lon coordinates. Allocation of CABLE's main variables also here. ! MPI: master only; necessary info will be received by MPI below !CALL load_parameters( met, air, ssnow, veg, bgc, & ! soil, canopy, rough, rad, sum_flux, & ! bal, logn, vegparmnew, casabiome, casapool, & ! casaflux, casamet, casabal, phen, C%EMSOIL, & ! C%TFRZ ) SPINLOOP:DO YEAR: DO YYYY= CABLE_USER%YearStart, CABLE_USER%YearEnd CurYear = YYYY IF ( leaps .AND. IS_LEAPYEAR( YYYY ) ) THEN LOY = 366 ELSE LOY = 365 ENDIF ! MPI: receive from master ending time fields CALL MPI_Bcast (kend, 1, MPI_INTEGER, 0, comm, ierr) IF ( CALL1 ) THEN IF (.NOT.spinup) spinConv=.TRUE. ! MPI: bcast to workers so that they don't need to open the met ! file themselves CALL MPI_Bcast (dels, 1, MPI_REAL, 0, comm, ierr) ! MPI: need to know extents before creating datatypes CALL find_extents ! MPI: receive decomposition info from the master CALL worker_decomp(comm) ! MPI: in overlap version sends and receives occur on separate comms CALL MPI_Comm_dup (comm, icomm, ierr) CALL MPI_Comm_dup (comm, ocomm, ierr) ! MPI: data set in load_parameter is now received from ! the master CALL worker_cable_params(comm, met,air,ssnow,veg,bgc,soil,canopy,& & rough,rad,sum_flux,bal) !mrd561 debug WRITE(logn,*) ' ssat_vec min',MINVAL(soil%ssat_vec),MINLOC(soil%ssat_vec) WRITE(logn,*) ' sfc_vec min',MINVAL(soil%sfc_vec),MINLOC(soil%sfc_vec) WRITE(logn,*) ' wb min',MINVAL(ssnow%wb),MINLOC(ssnow%wb) CALL flush(logn) IF (check%ranges /= NO_CHECK) THEN WRITE (logn, *) "Checking parameter ranges" CALL constant_check_range(soil, veg, 0, met) END IF IF (cable_user%call_climate) THEN CALL worker_climate_types(comm, climate, ktauday ) ENDIF ! MPI: mvtype and mstype send out here instead of inside worker_casa_params ! so that old CABLE carbon module can use them. (BP May 2013) CALL MPI_Bcast (mvtype, 1, MPI_INTEGER, 0, comm, ierr) CALL MPI_Bcast (mstype, 1, MPI_INTEGER, 0, comm, ierr) ! MPI: casa parameters received only if cnp module is active IF (icycle>0) THEN CALL worker_casa_params (comm,casabiome,casapool,casaflux,casamet,& & casabal,phen) ! MPI: POP restart received only if pop module AND casa are active IF ( CABLE_USER%CALL_POP ) CALL worker_pop_types (comm,veg,pop) END IF ! MPI: create inp_t type to receive input data from the master ! at the start of every timestep CALL worker_intype (comm,met,veg) ! MPI: casa parameters received only if cnp module is active ! MPI: create send_t type to send the results to the master ! at the end of every timestep CALL worker_outtype (comm,met,canopy,ssnow,rad,bal,air,soil,veg) ! MPI: casa parameters received only if cnp module is active ! MPI: create type to send casa results back to the master ! only if cnp module is active IF (icycle>0) THEN CALL worker_casa_type (comm, casapool,casaflux, & casamet,casabal, phen) IF ( CABLE_USER%CASA_DUMP_READ .OR. CABLE_USER%CASA_DUMP_WRITE ) & CALL worker_casa_dump_types(comm, casamet, casaflux, phen) WRITE(logn,*) 'cable_mpiworker, POPLUC: ', CABLE_USER%POPLUC WRITE(*,*) 'cable_mpiworker, POPLUC: ', CABLE_USER%POPLUC CALL flush(logn) IF ( CABLE_USER%POPLUC ) & CALL worker_casa_LUC_types( comm, casapool, casabal) ! MPI: casa parameters received only if cnp module is active END IF ! MPI: create type to send restart data back to the master ! only if restart file is to be created IF(output%restart) THEN CALL worker_restart_type (comm, canopy, air) END IF ! Open output file: ! MPI: only the master writes to the files !CALL open_output_file( dels, soil, veg, bgc, rough ) ssnow%otss_0 = ssnow%tgg(:,1) ssnow%otss = ssnow%tgg(:,1) canopy%fes_cor = 0. canopy%fhs_cor = 0. met%ofsd = 0.1 ! CALL worker_sumcasa_types(comm, sum_casapool, sum_casaflux) !count_sum_casa = 0 IF( icycle>0 .AND. spincasa) THEN WRITE(logn,*) 'EXT spincasacnp enabled with mloop= ', mloop CALL worker_spincasacnp(dels,kstart,kend,mloop,veg,soil,casabiome,casapool, & casaflux,casamet,casabal,phen,POP,climate,LALLOC, icomm, ocomm) SPINconv = .FALSE. CASAONLY = .TRUE. ktau_gl = 0 ktau = 0 ELSEIF ( casaonly .AND. (.NOT. spincasa) .AND. cable_user%popluc) THEN CALL worker_CASAONLY_LUC(dels,kstart,kend,veg,soil,casabiome,casapool, & casaflux,casamet,casabal,phen,POP,climate,LALLOC, & icomm, ocomm) SPINconv = .FALSE. ktau_gl = 0 ktau = 0 ENDIF ELSE IF (icycle.GT.0) THEN ! re-initalise annual flux sums casabal%FCgppyear =0.0 casabal%FCrpyear =0.0 casabal%FCnppyear =0.0 casabal%FCrsyear =0.0 casabal%FCneeyear =0.0 ENDIF ENDIF !CALL1 ! globally (WRT code) accessible kend through USE cable_common_module ktau_gl = 0 kwidth_gl = INT(dels) kend_gl = kend knode_gl = 0 IF (spincasa .OR. casaonly) THEN EXIT ENDIF if( .NOT. allocated(heat_cap_lower_limit) ) then allocate( heat_cap_lower_limit(mp,ms) ) heat_cap_lower_limit = 0.01 end if call spec_init_soil_snow(dels, soil, ssnow, canopy, met, bal, veg, heat_cap_lower_limit) ! IF (.NOT.spincasa) THEN ! time step loop over ktau KTAULOOP:DO ktau=kstart, kend ! increment total timstep counter ktau_tot = ktau_tot + 1 WRITE(logn,*) 'ktau -',ktau_tot CALL flush(logn) ! globally (WRT code) accessible kend through USE cable_common_module ktau_gl = ktau_gl + 1 ! somethings (e.g. CASA-CNP) only need to be done once per day ktauday=INT(24.0*3600.0/dels) !$ idoy = mod(ktau/ktauday,365) !$ IF(idoy==0) idoy=365 !$ !$ ! needed for CASA-CNP !$ nyear =INT((kend-kstart+1)/(365*ktauday)) ! some things (e.g. CASA-CNP) only need to be done once per day idoy =INT( MOD((REAL(ktau+koffset)/REAL(ktauday)),REAL(LOY))) IF ( idoy .EQ. 0 ) idoy = LOY ! needed for CASA-CNP nyear =INT((kend-kstart+1)/(LOY*ktauday)) canopy%oldcansto=canopy%cansto ! Get met data and LAI, set time variables. ! Rainfall input may be augmented for spinup purposes: met%ofsd = met%fsd(:,1) + met%fsd(:,2) ! MPI: input file read on the master only !CALL get_met_data( spinup, spinConv, met, soil, & ! rad, veg, kend, dels, C%TFRZ, ktau ) ! MPI: receive input data for this step from the master IF ( .NOT. CASAONLY ) THEN CALL MPI_Recv (MPI_BOTTOM, 1, inp_t, 0, ktau_gl, icomm, stat, ierr) ! MPI: receive casa_dump_data for this step from the master ELSEIF ( IS_CASA_TIME("dread", yyyy, ktau, kstart, koffset, & kend, ktauday, logn) ) THEN CALL MPI_Recv (MPI_BOTTOM, 1, casa_dump_t, 0, ktau_gl, icomm, stat, ierr) END IF ! MPI: some fields need explicit init, because we don't transfer ! them for better performance ! in the serial version this is done in get_met_data ! after input has been read from the file met%tvair = met%tk met%tvrad = met%tk ! Feedback prognostic vcmax and daily LAI from casaCNP to CABLE IF (l_vcmaxFeedbk) CALL casa_feedback( ktau, veg, casabiome, & casapool, casamet ) IF (l_laiFeedbk) veg%vlai(:) = REAL(casamet%glai(:)) IF (cable_user%CALL_climate) & CALL cable_climate(ktau_tot,kstart,kend,ktauday,idoy,LOY,met, & climate, canopy, air, rad, dels, mp) IF (.NOT. allocated(c1)) ALLOCATE( c1(mp,nrb), rhoch(mp,nrb), xk(mp,nrb) ) ! CALL land surface scheme for this timestep, all grid points: CALL cbm( ktau, dels, air, bgc, canopy, met, bal, & rad, rough, soil, ssnow, sum_flux, veg, climate, xk, c1, rhoch ) ssnow%smelt = ssnow%smelt*dels ssnow%rnof1 = ssnow%rnof1*dels ssnow%rnof2 = ssnow%rnof2*dels ssnow%runoff = ssnow%runoff*dels !jhan this is insufficient testing. condition for !spinup=.false. & we want CASA_dump.nc (spinConv=.true.) IF(icycle >0) THEN CALL bgcdriver( ktau, kstart, kend, dels, met, & ssnow, canopy, veg, soil,climate, casabiome, & casapool, casaflux, casamet, casabal, & phen, pop, spinConv, spinup, ktauday, idoy, loy, & .FALSE., .FALSE., LALLOC ) ! IF(MOD((ktau-kstart+1),ktauday)==0) THEN CALL MPI_Send (MPI_BOTTOM,1, casa_t,0,ktau_gl,ocomm,ierr) ! ENDIF IF ( IS_CASA_TIME("write", yyyy, ktau, kstart, & koffset, kend, ktauday, logn) ) THEN ! write(logn,*) 'IN IS_CASA', casapool%cplant(:,1) ! CALL MPI_Send (MPI_BOTTOM,1, casa_t,0,ktau_gl,ocomm,ierr) ENDIF ! MPI: send the results back to the master IF( ((.NOT.spinup).OR.(spinup.AND.spinConv)) .AND. & IS_CASA_TIME("dwrit", yyyy, ktau, kstart, & koffset, kend, ktauday, logn)) & CALL MPI_Send (MPI_BOTTOM, 1, casa_dump_t, 0, ktau_gl, ocomm, ierr) ENDIF ! sumcflux is pulled out of subroutine cbm ! so that casaCNP can be called before adding the fluxes (Feb 2008, YP) CALL sumcflux( ktau, kstart, kend, dels, bgc, & canopy, soil, ssnow, sum_flux, veg, & met, casaflux, l_vcmaxFeedbk ) ! MPI: send the results back to the master CALL MPI_Send (MPI_BOTTOM, 1, send_t, 0, ktau_gl, ocomm, ierr) ! Write time step's output to file if either: we're not spinning up ! or we're spinning up and the spinup has converged: ! MPI: writing done only by the master !IF((.NOT.spinup).OR.(spinup.AND.spinConv)) & ! CALL write_output( dels, ktau, met, canopy, ssnow, & ! rad, bal, air, soil, veg, C%SBOLTZ, & ! C%EMLEAF, C%EMSOIL ) CALL1 = .FALSE. END DO KTAULOOP ! END Do loop over timestep ktau ! ELSE CALL1 = .FALSE. ! ENDIF CALL flush(logn) IF (icycle >0 .AND. cable_user%CALL_POP) THEN IF (CABLE_USER%POPLUC) THEN WRITE(logn,*) 'before MPI_Send casa_LUC' ! worker sends casa updates required for LUC calculations here CALL MPI_Send (MPI_BOTTOM, 1, casa_LUC_t, 0, 0, ocomm, ierr) WRITE(logn,*) 'after MPI_Send casa_LUC' ! master calls LUCDriver here ! worker receives casa and POP updates CALL MPI_Recv( POP%pop_grid(1), POP%np, pop_t, 0, 0, icomm, stat, ierr ) ENDIF ! one annual time-step of POP CALL POPdriver(casaflux,casabal,veg, POP) CALL worker_send_pop (POP, ocomm) IF (CABLE_USER%POPLUC) & CALL MPI_Recv (MPI_BOTTOM, 1, casa_LUC_t, 0, nyear, icomm, stat, ierr) ENDIF IF ( ((.NOT.spinup).OR.(spinup.AND.spinConv)).AND. & CABLE_USER%CALL_POP) THEN !CALL worker_send_pop (POP, ocomm) ENDIF END DO YEAR IF (spincasa .OR. casaonly) THEN EXIT ENDIF !jhan this is insufficient testing. condition for !spinup=.false. & we want CASA_dump.nc (spinConv=.true.) ! see if spinup (if conducting one) has converged: !IF(spinup.AND..NOT.spinConv) THEN ! ! ! Write to screen and log file: ! WRITE(*,'(A18,I3,A24)') ' Spinning up: run ',INT(ktau_tot/kend), & ! ' of data set complete...' ! WRITE(logn,'(A18,I3,A24)') ' Spinning up: run ',INT(ktau_tot/kend), & ! ' of data set complete...' ! ! ! IF not 1st run through whole dataset: ! IF( INT( ktau_tot/kend ) > 1 ) THEN ! ! ! evaluate spinup ! IF( ANY( ABS(ssnow%wb-soilMtemp)>delsoilM).OR. & ! ANY(ABS(ssnow%tgg-soilTtemp)>delsoilT) ) THEN ! ! ! No complete convergence yet ! PRINT *, 'ssnow%wb : ', ssnow%wb ! PRINT *, 'soilMtemp: ', soilMtemp ! PRINT *, 'ssnow%tgg: ', ssnow%tgg ! PRINT *, 'soilTtemp: ', soilTtemp ! ! ELSE ! spinup has converged ! ! spinConv = .TRUE. ! ! Write to screen and log file: ! WRITE(*,'(A33)') ' Spinup has converged - final run' ! WRITE(logn,'(A52)') & ! ' Spinup has converged - final run - writing all data' ! WRITE(logn,'(A37,F8.5,A28)') & ! ' Criteria: Change in soil moisture < ', & ! delsoilM, ' in any layer over whole run' ! WRITE(logn,'(A40,F8.5,A28)' ) & ! ' Change in soil temperature < ', & ! delsoilT, ' in any layer over whole run' ! END IF ! ELSE ! allocate variables for storage ! ! ALLOCATE( soilMtemp(mp,ms), soilTtemp(mp,ms) ) ! ! END IF ! ! ! store soil moisture and temperature ! soilTtemp = ssnow%tgg ! soilMtemp = REAL(ssnow%wb) !ELSE ! ! if not spinning up, or spin up has converged, exit: ! EXIT ! !END IF ! MPI: learn from the master whether it's time to quit CALL MPI_Bcast (loop_exit, 1, MPI_LOGICAL, 0, comm, ierr) IF (loop_exit) THEN EXIT END IF END DO SPINLOOP IF (icycle > 0 .AND. (.NOT.spincasa).AND. (.NOT.casaonly)) THEN ! MPI: send casa results back to the master CALL MPI_Send (MPI_BOTTOM, 1, casa_t, 0, ktau_gl, ocomm, ierr) ! MPI: output file written by master only !CALL casa_poolout( ktau, veg, soil, casabiome, & ! casapool, casaflux, casamet, casabal, phen ) ! MPI: output file written by master only !CALL casa_fluxout( nyear, veg, soil, casabal, casamet) END IF ! Write restart file if requested: IF(output%restart .AND. (.NOT. CASAONLY)) THEN ! MPI: send variables that are required by create_restart CALL MPI_Send (MPI_BOTTOM, 1, restart_t, 0, ktau_gl, comm, ierr) ! MPI: output file written by master only IF (cable_user%CALL_climate) & CALL MPI_Send (MPI_BOTTOM, 1, climate_t, 0, ktau_gl, comm, ierr) END IF ! MPI: cleanup CALL worker_end(icycle, output%restart) ! MPI: open and close by master only ! Close met data input file: !CALL close_met_file ! MPI: open and close by master only ! Close output file and deallocate main variables: !CALL close_output_file( bal, air, bgc, canopy, met, & ! rad, rough, soil, ssnow, & ! sum_flux, veg ) !WRITE(logn,*) bal%wbal_tot, bal%ebal_tot, bal%ebal_tot_cncheck ! Close log file ! MPI: closes handle to /dev/null in workers CLOSE(logn) RETURN END SUBROUTINE mpidrv_worker ! ============== PRIVATE SUBROUTINES USED ONLY BY THE MPI WORKERS =============== ! MPI: receives grid decomposition info from the master SUBROUTINE worker_decomp (comm) USE mpi USE cable_def_types_mod, ONLY: mland, mp IMPLICIT NONE INTEGER, INTENT(IN) :: comm ! MPI communicator to talk to the workers INTEGER :: stat(MPI_STATUS_SIZE), ierr ! receive number of landpoints assigned to this worker CALL MPI_Recv (mland, 1, MPI_INTEGER, 0, 0, comm, stat, ierr) ! receive number of land patches assigned to this worker CALL MPI_Recv (mp, 1, MPI_INTEGER, 0, 0, comm, stat, ierr) RETURN END SUBROUTINE worker_decomp ! MPI: creates param_t type for the worker to receive the default parameters ! from the master process ! then receives the parameters ! and finally frees the MPI type SUBROUTINE worker_cable_params (comm,met,air,ssnow,veg,bgc,soil,canopy,& rough,rad,sum_flux,bal) USE mpi USE cable_def_types_mod USE cable_IO_vars_module USE cable_input_module, ONLY: allocate_cable_vars USE cable_common_module, ONLY: calcsoilalbedo IMPLICIT NONE ! subroutine arguments INTEGER, INTENT(IN) :: comm ! MPI communicator TYPE (met_type), INTENT(OUT) :: met TYPE (air_type), INTENT(OUT) :: air TYPE (soil_snow_type), INTENT(OUT) :: ssnow TYPE (veg_parameter_type), INTENT(OUT) :: veg TYPE (bgc_pool_type), INTENT(OUT) :: bgc TYPE (soil_parameter_type), INTENT(OUT) :: soil TYPE (canopy_type), INTENT(OUT) :: canopy TYPE (roughness_type), INTENT(OUT) :: rough TYPE (radiation_type),INTENT(OUT) :: rad TYPE (sum_flux_type), INTENT(OUT) :: sum_flux TYPE (balances_type), INTENT(OUT) :: bal ! local vars ! temp arrays for marshalling all fields into a single struct INTEGER, ALLOCATABLE, DIMENSION(:) :: blen INTEGER(KIND=MPI_ADDRESS_KIND), ALLOCATABLE, DIMENSION(:) :: displs INTEGER, ALLOCATABLE, DIMENSION(:) :: types ! temp vars for verifying block number and total length of inp_t INTEGER(KIND=MPI_ADDRESS_KIND) :: text, tmplb INTEGER :: tsize INTEGER :: stat(MPI_STATUS_SIZE), ierr INTEGER :: landp_t, patch_t, param_t INTEGER :: r1len, r2len, i1len, llen ! block lengths INTEGER :: bidx ! block index INTEGER :: ntyp ! total number of blocks INTEGER :: rank, ierr2, rcount, pos CHARACTER, DIMENSION(:), ALLOCATABLE :: rbuf CALL MPI_Comm_rank (comm, rank, ierr) ! mp and mland should have been received previously by ! worker_decomp ! creates types to receive slices of landpt and patch arrays from the master CALL decomp_types (landp_t, patch_t) ! Allocate spatial heterogeneity variables: ALLOCATE(landpt(mland)) ! and receive own slice from the master CALL MPI_Recv (landpt, mland, landp_t, 0, 0, comm, stat, ierr) CALL allocate_cable_vars(air,bgc,canopy,met,bal,rad,rough,soil,ssnow, & sum_flux,veg,mp) ! receive slice of patch array that was allocated above inside ! allocate_cable_vars CALL MPI_Recv (patch, mp, patch_t, 0, 0, comm, stat, ierr) ! MPI: TODO: probably not a bad idea to free landp_t and patch_t types ntyp = nparam ! ntyp increases if include ... Ticket #27 IF (calcsoilalbedo) THEN ntyp = nparam + 1 END IF ALLOCATE (blen(ntyp)) ALLOCATE (displs(ntyp)) ALLOCATE (types(ntyp)) ! default type is byte, to be overriden for multi-D types types = MPI_BYTE r1len = mp * extr1 r2len = mp * extr2 i1len = mp * extid llen = mp * extl bidx = 0 ! the order of variables follows argument list ! the order of fields within follows alloc_*_type subroutines ! ----------- met -------------- bidx = bidx + 1 CALL MPI_Get_address (met%ca, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%year, displs(bidx), ierr) blen(bidx) = i1len bidx = bidx + 1 CALL MPI_Get_address (met%moy, displs(bidx), ierr) blen(bidx) = i1len bidx = bidx + 1 CALL MPI_Get_address (met%doy, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%hod, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%fsd, displs(bidx), ierr) blen(bidx) = swb * r1len bidx = bidx + 1 CALL MPI_Get_address (met%fld, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%precip, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%precip_sn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%tk, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%tvair, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%tvrad, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%pmb, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%ua, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%qv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%qvair, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%da, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%dva, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (met%coszen, displs(bidx), ierr) blen(bidx) = r1len ! ----------- air -------------- bidx = bidx + 1 CALL MPI_Get_address (air%rho, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%volm, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%rlam, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%qsat, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%epsi, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%visc, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%psyc, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%dsatdk, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (air%cmolar, displs(bidx), ierr) blen(bidx) = r1len ! ----------- ssnow -------------- bidx = bidx + 1 CALL MPI_Get_address (ssnow%dtmlt, displs(bidx), ierr) blen(bidx) = 3 * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%pudsto, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%pudsmx, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%albsoilsn, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%cls, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%dfn_dtg, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%dfh_dtg, displs(bidx), ierr) blen(bidx) = r1len !INH - REV_CORR bidx = bidx + 1 CALL MPI_Get_address (ssnow%dfe_dtg, displs(bidx), ierr) blen(bidx) = r1len !INH - REV_CORR - no longer needed bidx = bidx + 1 CALL MPI_Get_address (ssnow%dfe_ddq, displs(bidx), ierr) blen(bidx) = r1len !INH - REV_CORR - no longer needed bidx = bidx + 1 CALL MPI_Get_address (ssnow%ddq_dtg, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%evapsn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%fwtop, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%fwtop1, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%fwtop2, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%fwtop3, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%gammzz, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%isflag, displs(bidx), ierr) blen(bidx) = i1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%osnowd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%potev, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%pwb_min, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%runoff, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%rnof1, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%rnof2, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%rtsoil, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%sconds, displs(bidx), ierr) blen(bidx) = msn * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%sdepth, displs(bidx), ierr) blen(bidx) = msn * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%smass, displs(bidx), ierr) blen(bidx) = msn * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%snage, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%snowd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%smelt, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%ssdn, displs(bidx), ierr) blen(bidx) = msn * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%ssdnn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tgg, displs(bidx), ierr) blen(bidx) = ms * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tggsn, displs(bidx), ierr) blen(bidx) = msn * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tss, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wb, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wbfice, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wbice, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wblf, displs(bidx), ierr) blen(bidx) = ms * r2len ! additional for sli bidx = bidx + 1 CALL MPI_Get_address (ssnow%S, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%Tsoil, displs(bidx), ierr) blen(bidx) = ms * r2len !$ bidx = bidx + 1 CALL MPI_Get_address (ssnow%thetai, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%snowliq, displs(bidx), ierr) blen(bidx) = 3 * r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%Tsurface, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%h0, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%nsnow, displs(bidx), ierr) blen(bidx) = I1len ! end additional for sli bidx = bidx + 1 CALL MPI_Get_address (ssnow%wbtot, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wb_lake, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%sinfil, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%evapfbl, displs(bidx), ierr) blen(bidx) = ms * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%qstss, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wetfac, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%owetfac, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%t_snwlr, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tggav, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%otss, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%otss_0, displs(bidx), ierr) blen(bidx) = r1len ! ----------- veg -------------- bidx = bidx + 1 CALL MPI_Get_address (veg%canst1, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%dleaf, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%ejmax, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%frac4, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%froot, displs(bidx), ierr) blen(bidx) = ms * r1len bidx = bidx + 1 CALL MPI_Get_address (veg%hc, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%iveg, displs(bidx), ierr) blen(bidx) = i1len bidx = bidx + 1 CALL MPI_Get_address (veg%meth, displs(bidx), ierr) ! Maciej: veg%meth is REAL ! blen(bidx) = i1len blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%rp20, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%rpcoef, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%shelrb, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%wai, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%vegcf, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%tminvj, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%tmaxvj, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%vbeta, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%xalbnir, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%vcmax, displs(bidx), ierr) blen(bidx) = r1len ! bidx = bidx + 1 ! CALL MPI_Get_address (veg%vlai, displs(bidx), ierr) ! blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%xfang, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%extkn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%deciduous, displs(bidx), ierr) ! Maciej: deciduous is logical ! blen(bidx) = r1len blen(bidx) = llen bidx = bidx + 1 CALL MPI_Get_address (veg%a1gs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%d0gs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%alpha, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%convex, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%cfrd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%gswmin, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%conkc0, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%conko0, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%ekc, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%eko, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%clitt, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (veg%zr, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (veg%gamma, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (veg%refl, displs(bidx), ierr) blen(bidx) = 2 * r1len bidx = bidx + 1 CALL MPI_Get_address (veg%taul, displs(bidx), ierr) blen(bidx) = 2 * r1len bidx = bidx + 1 CALL MPI_Get_address (veg%disturbance_interval, displs(bidx), ierr) blen(bidx) = 2 * i1len bidx = bidx + 1 CALL MPI_Get_address (veg%disturbance_intensity, displs(bidx), ierr) ! Maciej: disturbance_intensity is REAL(r_2) ! blen(bidx) = 2 * r1len blen(bidx) = 2 * r2len ! Ticket #56, adding new veg parms bidx = bidx + 1 CALL MPI_Get_address (veg%g0, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%g1, displs(bidx), ierr) blen(bidx) = r1len ! Ticket #56, finish adding new veg parms ! ----------- bgc -------------- bidx = bidx + 1 CALL MPI_Get_address (bgc%cplant, displs(bidx), ierr) blen(bidx) = ncp * r1len bidx = bidx + 1 CALL MPI_Get_address (bgc%csoil, displs(bidx), ierr) blen(bidx) = ncs * r1len bidx = bidx + 1 CALL MPI_Get_address (bgc%ratecp, displs(bidx), ierr) blen(bidx) = ncp * extr1 bidx = bidx + 1 CALL MPI_Get_address (bgc%ratecs, displs(bidx), ierr) blen(bidx) = ncs * extr1 ! ----------- soil -------------- bidx = bidx + 1 CALL MPI_Get_address (soil%albsoil, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (soil%bch, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%c3, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%clay, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%cnsd, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%css, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%hsbh, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%hyds, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%i2bp3, displs(bidx), ierr) ! Maciej: i2bp3 is REAL ! blen(bidx) = i1len blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%ibp2, displs(bidx), ierr) ! Maciej: ibp2 is REAL ! blen(bidx) = i1len blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%isoilm, displs(bidx), ierr) ! Maciej isoilm is INTEGER ! blen(bidx) = r1len blen(bidx) = i1len bidx = bidx + 1 CALL MPI_Get_address (soil%rhosoil, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%rs20, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%sand, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%sfc, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%silt, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%ssat, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%sucs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (soil%swilt, displs(bidx), ierr) blen(bidx) = r1len ! extra for sli bidx = bidx + 1 CALL MPI_Get_address (soil%zeta, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%fsatmax, displs(bidx), ierr) blen(bidx) = r2len ! end extra for sil bidx = bidx + 1 CALL MPI_Get_address (soil%zse, displs(bidx), ierr) blen(bidx) = ms * extr1 bidx = bidx + 1 CALL MPI_Get_address (soil%zshh, displs(bidx), ierr) blen(bidx) = (ms + 1) * extr1 ! pass soilcolour albedo as well if including Ticket #27 IF (calcsoilalbedo) THEN bidx = bidx + 1 CALL MPI_Get_address (soil%soilcol, displs(bidx), ierr) blen(bidx) = r1len END IF ! ----------- canopy -------------- bidx = bidx + 1 CALL MPI_Get_address (canopy%fess, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%fesp, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%cansto, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%oldcansto, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%cduv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%delwc, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%dewmm, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%dgdtg, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%fe, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fh, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fpn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%frp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%frpw, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%frpr, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%frs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fnee, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%frday, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fnv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fev, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fevc, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%fevw, displs(bidx), ierr) blen(bidx) = r1len ! bidx = bidx + 1 ! CALL MPI_Get_address (canopy%potev_c, displs(bidx), ierr) ! blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%fhv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fhvw, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fns, displs(bidx), ierr) blen(bidx) = r1len !INH - REV_CORR - temporary? bidx = bidx + 1 CALL MPI_Get_address (canopy%fns_cor, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fes, displs(bidx), ierr) blen(bidx) = r2len !INH - REV_CORR - temporary? bidx = bidx + 1 CALL MPI_Get_address (canopy%fes_cor, displs(bidx), ierr) blen(bidx) = r2len !INH - SSEB - temporary? !bidx = bidx + 1 !CALL MPI_Get_address (canopy%fescor_upp, displs(bidx), ierr) !blen(bidx) = r2len !INH - SSEB - temporary? !bidx = bidx + 1 !CALL MPI_Get_address (canopy%fescor_low, displs(bidx), ierr) !blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%fhs, displs(bidx), ierr) blen(bidx) = r1len !INH - REV_CORR - temporary? bidx = bidx + 1 CALL MPI_Get_address (canopy%fhs_cor, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fwet, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%ga, displs(bidx), ierr) blen(bidx) = r1len !INH - REV_CORR - temporary? bidx = bidx + 1 CALL MPI_Get_address (canopy%ga_cor, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%ghflux, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%precis, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%qscrn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%rnet, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%segg, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%sghflux, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%spill, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%through, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%tscrn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%tv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%us, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%uscrn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%vlaiw, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%rghlai, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%wcint, displs(bidx), ierr) blen(bidx) = r1len ! bidx = bidx + 1 ! CALL MPI_Get_address (canopy%rwater, displs(bidx), ierr) ! blen(bidx) = ms * r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%evapfbl, displs(bidx), ierr) ! MPI: gol124: changed to r1 when Bernard ported to CABLE_r491 blen(bidx) = ms * r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%epot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fnpp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fevw_pot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%gswx_T, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%cdtq, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%wetfac_cs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%fwsoil, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (canopy%gswx, displs(bidx), ierr) blen(bidx) = mf * r1len bidx = bidx + 1 CALL MPI_Get_address (canopy%zetar, displs(bidx), ierr) blen(bidx) = niter * r1len ! ------- rough ------- bidx = bidx + 1 CALL MPI_Get_address (rough%coexp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%disp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%hruff, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%hruff_grmx, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%rt0us, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%rt1usa, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%rt1usb, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%rt1, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%term2, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%term3, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%term5, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%term6, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%usuh, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%za_uv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%za_tq, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%z0m, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%zref_uv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%zref_tq, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%zruffs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%z0soilsn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rough%z0soil, displs(bidx), ierr) blen(bidx) = r1len ! --------rad -------- bidx = bidx + 1 CALL MPI_Get_address (rad%albedo, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%extkb, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%extkd2, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%extkd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%flws, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%fvlai, displs(bidx), ierr) blen(bidx) = mf * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%gradis, displs(bidx), ierr) blen(bidx) = mf * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%latitude, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%lwabv, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%qcan, displs(bidx), ierr) blen(bidx) = mf * nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%qssabs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%rhocdf, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%rniso, displs(bidx), ierr) blen(bidx) = mf * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%scalex, displs(bidx), ierr) blen(bidx) = mf * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%transd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%trad, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%reffdf, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%reffbm, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%extkbm, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%extkdm, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%fbeam, displs(bidx), ierr) blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%cexpkbm, displs(bidx), ierr) ! Maciej: cexpkbm is mp*swb ! blen(bidx) = nrb * r1len blen(bidx) = swb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%cexpkdm, displs(bidx), ierr) ! Maciej: cexpkdm is mp*swb ! blen(bidx) = nrb * r1len blen(bidx) = swb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%rhocbm, displs(bidx), ierr) ! Maciej: rhocbm is mp*nrb ! blen(bidx) = swb * r1len blen(bidx) = nrb * r1len bidx = bidx + 1 CALL MPI_Get_address (rad%transb, displs(bidx), ierr) blen(bidx) = r1len ! ------- sum_flux ----- bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumpn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumrp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumrpw, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumrpr, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumrs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumrd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%dsumpn, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%dsumrp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%dsumrs, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%dsumrd, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumxrp, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (sum_flux%sumxrs, displs(bidx), ierr) blen(bidx) = r1len ! ------- bal ---- bidx = bidx + 1 CALL MPI_Get_address (bal%drybal, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%ebal, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%ebal_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%ebal_cncheck, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%ebal_tot_cncheck, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%evap_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%osnowd0, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%precip_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%rnoff_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%wbal, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%wbal_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%wbtot0, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%wetbal, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%owbtot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%evapc_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%evaps_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%rnof1_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%rnof2_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%snowdc_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%wbal_tot1, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%delwc_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%qasrf_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%qfsrf_tot, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%qssrf_tot, displs(bidx), ierr) blen(bidx) = r1len ! additional field missing from previous versions; ! added when trying to fix a bug in the new mpi code ! the order of these new fields follows the order of their ! declaration in cable_define_types.F90 bidx = bidx + 1 CALL MPI_Get_address (bal%ebaltr, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%ebal_tottr, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (bal%cansto0, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%iantrct, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tss_p, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%deltss, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%owb1, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%wbtot1, displs(bidx), ierr) blen(bidx) = r1len ! Maciej: duplicate! ! bidx = bidx + 1 ! CALL MPI_Get_address (ssnow%wbtot1, displs(bidx), ierr) ! blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tprecip, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tevap, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%trnoff, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%totenbal, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%totenbal2, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%fland, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%ifland, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%tilefrac, displs(bidx), ierr) blen(bidx) = n_tiles * r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%qasrf, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%qfsrf, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (ssnow%qssrf, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (veg%vlaimax, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%albedo_T, displs(bidx), ierr) blen(bidx) = r1len bidx = bidx + 1 CALL MPI_Get_address (rad%longitude, displs(bidx), ierr) blen(bidx) = r1len !mrd add new GW parameters here !2D bidx = bidx + 1 CALL MPI_Get_address (soil%ssat_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%sucs_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%hyds_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%bch_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%watr, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%swilt_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%sfc_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%zse_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%css_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%cnsd_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%clay_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%sand_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%silt_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%org_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%rhosoil_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%smpc_vec, displs(bidx), ierr) blen(bidx) = ms * r2len bidx = bidx + 1 CALL MPI_Get_address (soil%wbc_vec, displs(bidx), ierr) blen(bidx) = ms * r2len !1d bidx = bidx + 1 CALL MPI_Get_address (soil%GWssat_vec, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWsucs_vec, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWhyds_vec, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWbch_vec, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWwatr, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWz, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%GWdz, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%slope, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (soil%slope_std, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (ssnow%GWwb, displs(bidx), ierr) blen(bidx) = r2len ! MPI: sanity check IF (bidx /= ntyp) THEN WRITE (*,*) 'worker ',rank,' invalid number of param_t fields',bidx,', fix it!' CALL MPI_Abort (comm, 1, ierr) END IF CALL MPI_Type_create_struct (bidx, blen, displs, types, param_t, ierr) CALL MPI_Type_commit (param_t, ierr) CALL MPI_Type_size (param_t, tsize, ierr) CALL MPI_Type_get_extent (param_t, tmplb, text, ierr) WRITE (*,*) 'worker param_t blocks, size, extent and lb: ',rank,bidx,tsize,text,tmplb ! MPI: check whether total size of received data equals total ! data sent by all the workers CALL MPI_Reduce (tsize, MPI_DATATYPE_NULL, 1, MPI_INTEGER, MPI_SUM, 0, comm, ierr) DEALLOCATE(types) DEALLOCATE(displs) DEALLOCATE(blen) ! if anything went wrong the master will mpi_abort ! which mpi_recv below is going to catch... ! so, now receive all the parameters ! CALL MPI_Recv (MPI_BOTTOM, 1, param_t, 0, 0, comm, stat, ierr) ! Maciej: buffered recv + unpac version ALLOCATE (rbuf(tsize)) CALL MPI_Recv (rbuf, tsize, MPI_BYTE, 0, 0, comm, stat, ierr) CALL MPI_Get_count (stat, param_t, rcount, ierr2) IF (ierr == MPI_SUCCESS .AND. ierr2 == MPI_SUCCESS .AND. rcount == 1) THEN pos = 0 CALL MPI_Unpack (rbuf, tsize, pos, MPI_BOTTOM, rcount, param_t, & comm, ierr) IF (ierr /= MPI_SUCCESS) WRITE(*,*)'cable param unpack error, rank: ',rank,ierr ELSE WRITE(*,*)'cable param recv rank err err2 rcount: ',rank, ierr, ierr2, rcount END IF DEALLOCATE(rbuf) ! finally free the MPI type CALL MPI_Type_Free (param_t, ierr) ! all CABLE parameters have been received from the master by now RETURN END SUBROUTINE worker_cable_params ! MPI: creates param_t type for the worker to receive the default casa ! parameters from the master process ! then receives them ! and finally frees the MPI type SUBROUTINE worker_casa_params (comm,casabiome,casapool,casaflux,casamet,& casabal,phen) USE mpi USE cable_def_types_mod USE casavariable USE phenvariable IMPLICIT NONE ! sub arguments INTEGER, INTENT(IN) :: comm ! MPI communicator ! TODO: have these variables been already allocated? TYPE (casa_biome) , INTENT(OUT) :: casabiome TYPE (casa_pool) , INTENT(OUT) :: casapool TYPE (casa_flux) , INTENT(OUT) :: casaflux TYPE (casa_met) , INTENT(OUT) :: casamet TYPE (casa_balance), INTENT(OUT) :: casabal TYPE (phen_variable), INTENT(OUT) :: phen ! local vars ! temp arrays for marshalling all fields into a single struct INTEGER, ALLOCATABLE, DIMENSION(:) :: blen INTEGER(KIND=MPI_ADDRESS_KIND), ALLOCATABLE, DIMENSION(:) :: displs INTEGER, ALLOCATABLE, DIMENSION(:) :: types ! temp vars for verifying block number and total length of inp_t INTEGER(KIND=MPI_ADDRESS_KIND) :: text, tmplb INTEGER :: tsize INTEGER :: stat(MPI_STATUS_SIZE), ierr ! INTEGER :: landp_t, patch_t, param_t INTEGER :: casa_t INTEGER :: r1len, r2len, I1LEN, llen ! block lengths INTEGER :: bidx ! block index INTEGER :: ntyp ! total number of blocks INTEGER :: rank, off, ierr2, rcount, pos CHARACTER, DIMENSION(:), ALLOCATABLE :: rbuf off = 1 CALL MPI_Comm_rank (comm, rank, ierr) IF (.NOT. ASSOCIATED (casabiome%ivt2)) THEN WRITE (*,*) 'worker alloc casa and phen var with m patches: ',rank,mp CALL alloc_casavariable (casabiome, casapool, & & casaflux, casamet, casabal, mp) CALL alloc_phenvariable (phen, mp) END IF ntyp = ncasaparam ALLOCATE (blen(ntyp)) ALLOCATE (displs(ntyp)) ALLOCATE (types(ntyp)) ! default type is byte, to be overriden for multi-D types types = MPI_BYTE r1len = mp * extr1 r2len = mp * extr2 I1LEN = mp * extid llen = mp * extl bidx = 0 ! ------- casabiome ----- bidx = bidx + 1 CALL MPI_Get_address (casabiome%ivt2, displs(bidx), ierr) blen(bidx) = mvtype * extid bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkleafcoldmax, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkleafcoldexp, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkleafdrymax, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkleafdryexp, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%glaimax, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%glaimin, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%sla, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratiofrootleaf, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%kroot, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%krootlen, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%rootdepth, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%kuptake, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%kminN, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%KuplabP, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%kclabrate, displs(bidx), ierr) blen(bidx) = mvtype * extr2 !=================================================================== bidx = bidx + 1 CALL MPI_Get_address (casabiome%xnpmax, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%q10soil, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkoptlitter, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkoptsoil, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%maxfinelitter, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%maxcwd, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%prodptase, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%costnpup, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkplab, displs(bidx), ierr) blen(bidx) = mso * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkpsorb, displs(bidx), ierr) blen(bidx) = mso * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%xkpocc, displs(bidx), ierr) blen(bidx) = mso * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%nintercept, displs(bidx), ierr) blen(bidx) = mvtype * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%nslope, displs(bidx), ierr) blen(bidx) = mvtype * extr2 !=================================================================== bidx = bidx + 1 CALL MPI_Get_address (casabiome%plantrate, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%rmplant, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%fracnpptoP, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%fraclignin, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%fraclabile, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratioNCplantmin, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratioNCplantmax, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratioPCplantmin, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratioPCplantmax, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%fracLigninplant, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ftransNPtoL, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ftransPPtoL, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%litterrate, displs(bidx), ierr) blen(bidx) = mvtype * mlitter * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%soilrate, displs(bidx), ierr) blen(bidx) = mvtype * msoil * extr2 ! added by ln bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratioNPplantmin, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 bidx = bidx + 1 CALL MPI_Get_address (casabiome%ratioNPplantmax, displs(bidx), ierr) blen(bidx) = mvtype * mplant * extr2 ! ------ casapool ---- bidx = bidx + 1 CALL MPI_Get_address (casapool%Clabile, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dClabiledt, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Cplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Nplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Pplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dCplantdt, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dNplantdt, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dPplantdt, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNCplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioPCplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Nsoilmin, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Psoillab, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Psoilsorb, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Psoilocc, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dNsoilmindt, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dPsoillabdt, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dPsoilsorbdt, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dPsoiloccdt, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Clitter, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Nlitter, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Plitter, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dClitterdt, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dNlitterdt, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dPlitterdt, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNClitter, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioPClitter, displs(bidx), ierr) blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Csoil, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Nsoil, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%Psoil, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dCsoildt, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dNsoildt, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%dPsoildt, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNCsoil, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioPCsoil, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNCsoilnew, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNCsoilmin, displs(bidx), ierr) blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNCsoilmax, displs(bidx), ierr) blen(bidx) = msoil * r2len ! added by LN bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNPplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNPlitter, displs(bidx), ierr) ! blen(bidx) = mplant * r2len ! Maciej blen(bidx) = mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%ratioNPsoil, displs(bidx), ierr) ! blen(bidx) = mplant * r2len ! Maciej blen(bidx) = msoil * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%cwoodprod, displs(bidx), ierr) blen(bidx) = mwood * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%nwoodprod, displs(bidx), ierr) blen(bidx) = mwood * r2len bidx = bidx + 1 CALL MPI_Get_address (casapool%pwoodprod, displs(bidx), ierr) blen(bidx) = mwood * r2len ! ------- casaflux ---- bidx = bidx + 1 CALL MPI_Get_address (casaflux%Cgpp, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Cnpp, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Crp, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Crgplant, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nminfix, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nminuptake, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Plabuptake, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Clabloss, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%fracClabile, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%fracCalloc, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%fracNalloc, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%fracPalloc, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Crmplant, displs(bidx), ierr) blen(bidx) = mplant * r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%kplant, displs(bidx), ierr) blen(bidx) = mplant * r2len ! 3D bidx = bidx + 1 CALL MPI_Get_address (casaflux%fromPtoL, displs(bidx), ierr) blen(bidx) = mplant * mlitter * r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Cnep, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Crsoil, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nmindep, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nminloss, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nminleach, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nupland, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nlittermin, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nsmin, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nsimm, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Nsnet, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%fNminloss, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%fNminleach, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Pdep, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Pwea, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Pleach, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Ploss, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Pupland, displs(bidx), ierr) blen(bidx) = r2len bidx = bidx + 1 CALL MPI_Get_address (casaflux%Plittermin, displs(bidx), ierr)