ecearth3/sources/lpjg/framework/oasis-cpp-interface-ftn.F90

! OASIS-MCT calls for LPJ-GUESS. 
! March 2015 - removed all old prism calls

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_init_comp_(int *, char *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_init_comp(compid,model_name)

    use mod_oasis

    ! Arguments
    integer,         intent(out) :: compid
    character(len=4),intent(in)  :: model_name
    
    ! Locals
    integer :: ierror
 
    print*, "LPJ-GUESS - calling oasis_init_comp"   
    call oasis_init_comp(compid,model_name,ierror)
    print*, "LPJ-GUESS - oasis_init_comp returned with ierror =",ierror
    print*, "LPJ-GUESS - oasis_init_comp returned compid = ",compid
   
    oasismct_init_comp = ierror    
    return
end function oasismct_init_comp

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_get_localcomm_(int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_get_localcomm(localcommid)

    use mod_oasis

    ! Arguments
    integer,         intent(out) :: localcommid
    
    ! Locals
    integer :: ierror,lcid
 
    print*, "LPJ-GUESS - calling oasis_get_localcomm"  
    call oasis_get_localcomm(lcid, ierror)
    print*, "LPJ-GUESS - oasis_get_localcomm returned ierror =",ierror
    print*, "LPJ-GUESS - localcomm = ",lcid

    localcommid = lcid
 
    oasismct_get_localcomm = ierror    
    return
end function oasismct_get_localcomm

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_create_couplcomm_(int, int, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_create_couplcomm(myrank, loccommid, cplcommid)

    use mod_oasis
    use mpi
	
    ! Arguments
    integer,         intent(in) :: myrank
    integer,         intent(in) :: loccommid
    integer,         intent(out) :: cplcommid
    
    ! Locals
    integer :: ierror
    integer :: icpl
	
	icpl = 1
	if (myrank /= 0) icpl = MPI_UNDEFINED
		
    print*, "LPJ-GUESS - calling oasis_create_couplcomm with icpl = ",icpl   
    call oasis_create_couplcomm(icpl, loccommid, cplcommid, ierror)
    print*, "LPJ-GUESS - oasis_create_couplcomm returned ierror =",ierror
   
    oasismct_create_couplcomm = ierror    
    return
end function oasismct_create_couplcomm

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_abort_(compid, routine_name, abort_message, return_code);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_abort(compid, routine_name, abort_message, return_code)

    use mod_oasis

    ! Arguments
    integer,          intent(in) :: compid
    character(len=24),intent(in) :: routine_name
    character(len=50),intent(in) :: abort_message
    integer,          intent(in) :: return_code
    ! Locals

    call oasis_abort(compid, routine_name, abort_message, return_code)

    oasismct_abort = 666
    return

end function oasismct_abort

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_terminate_(void);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_terminate()

    use mod_oasis

    ! Locals
    integer :: ierror

    call oasis_terminate(ierror)

    oasismct_terminate = ierror
    return
end function oasismct_terminate

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_def_partition_(int *, int *, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_def_partition(il_part_id,ig_paral,ig_paral_len)

    use mod_oasis

!    use mod_oasis_def_partition

    ! Arguments
    integer,intent(out) :: il_part_id
    integer,intent(in)  :: ig_paral_len
    integer,intent(in)  :: ig_paral(ig_paral_len)
    
    ! Locals
    integer :: ierror

	print*, "LPJ-GUESS - oasis_def_partition with ig_paral(1)=",ig_paral(1)
    print*, "LPJ-GUESS - oasis_def_partition with ig_paral(2)=",ig_paral(2)
    print*, "LPJ-GUESS - oasis_def_partition with ig_paral(3)=",ig_paral(3)

    call oasis_def_partition(il_part_id,ig_paral,ierror)
    print*, "LPJ-GUESS - called oasis_def_partition with ierror =",ierror
	
    oasismct_def_partition = ierror
    return
end function  oasismct_def_partition

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_def_var_(int *, char *, int *, int *, int *, int *, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_def_var(var_id,name,il_part_id,var_nodims,kinout,var_actual_shape,var_type)

    use mod_oasis

    ! Arguments
    integer,         intent(out) :: var_id
    character(len=8),intent(in)  :: name
    integer,         intent(in)  :: il_part_id
    integer,         intent(in)  :: var_nodims(2)
    integer,         intent(in)  :: kinout
    integer,         intent(in)  :: var_actual_shape(2*var_nodims(1))
    integer,         intent(in)  :: var_type

    ! Locals
    integer :: ierror
	
	print*, "LPJ-GUESS - calling oasis_def_var for ",name
    call oasis_def_var(var_id,name,il_part_id,var_nodims,kinout,var_actual_shape,var_type,ierror)
	print*, "LPJ-GUESS - oasis_def_var returned ierror =",ierror

    oasismct_def_var = ierror
    return
end function oasismct_def_var

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_enddef_(void);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_enddef()

    use mod_oasis

    ! Locals
    integer :: ierror

    print*, "LPJ-GUESS - calling oasis_enddef"
    call oasis_enddef(ierror)
    print*, "LPJ-GUESS - oasis_enddef returned ierror:",ierror

    oasismct_enddef = ierror
    return
end function oasismct_enddef

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_put_1d_(int *, int *, double *, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_put_1d(var_id,date,field_array,field_array_len)

    use mod_oasis

    ! Arguments
    integer,         intent(in) :: var_id
    integer,         intent(in) :: date
    integer,         intent(in) :: field_array_len
    double precision,intent(in) :: field_array(field_array_len)

    ! Locals
    integer :: info

    call oasis_put(var_id,date,field_array,info)

    oasismct_put_1d = info
    return
end function oasismct_put_1d

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_put_2d_(int *, int *, double *, int *, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_put_2d(var_id,date,field_array,field_array_len_x,field_array_len_y)

    use mod_oasis

    ! Arguments
    integer,         intent(in) :: var_id
    integer,         intent(in) :: date
    integer,         intent(in) :: field_array_len_x
    integer,         intent(in) :: field_array_len_y
    double precision,intent(in) :: field_array(field_array_len_x,field_array_len_y)

    ! Locals
    integer :: info

    call oasis_put(var_id,date,field_array,info)

    oasismct_put_2d = info
    return
end function oasismct_put_2d

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_get_1d_(int *, int *, double *, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_get_1d(var_id,date,field_array,field_array_len)

    use mod_oasis

    ! Arguments
    integer,         intent(in)  :: var_id
    integer,         intent(in)  :: date
    integer,         intent(in)  :: field_array_len
    double precision,intent(out) :: field_array(field_array_len)

    ! Locals
    integer :: info

    call oasis_get(var_id,date,field_array,info)

    oasismct_get_1d = info
    return
end function oasismct_get_1d

! ------------------------------------------------------------------------------------------------------
! *** int oasismct_get_2d_(int *, int *, double *, int *);
! ------------------------------------------------------------------------------------------------------
integer function oasismct_get_2d(var_id,date,field_array,field_array_len_x,field_array_len_y)

    use mod_oasis

    ! Arguments
    integer,         intent(in)  :: var_id
    integer,         intent(in)  :: date
    integer,         intent(in)  :: field_array_len_x,field_array_len_y
    double precision,intent(out) :: field_array(field_array_len_x,field_array_len_y)

    ! Locals
    integer :: info


    call oasis_get(var_id,date,field_array,info)

	! Outcomment some of these when debugging
	
    select case ( info )
		case ( OASIS_Recvd )
			print*, "  received from other model"
		case ( OASIS_FromRest )
			print*, "  read from restart file (directly or via coupler)"
		case ( OASIS_Input )
			print*, "  read from input file"
		case ( OASIS_RecvOut )
			print*, "  received from other model (directly or via coupler) and written to output file"
		case ( OASIS_FromRestOut )
			print*, "  read from restart file (directly or via coupler) and written to output file"
		case ( OASIS_Ok )
			print*, "  no field received; continue"
		case default
			print*, "Error from oasismct_get_2d, oasis_get in LPJ-GUESS"
    end select
    
    oasismct_get_2d = info
    return
end function oasismct_get_2d