ibuff(7) = plon               ! number of model longitudes       ibuff(8) = plat               ! number of model latitudes       ibuff(9) = msgpday            ! number of send/recv msgs per day       if (nstep == 0) ibuff(34) = 1 ! do extra albedo calculation on startup       ibuff(35) = 1                 ! use own restart info, not coupler's!! Constants!       pie       = acos(-1.)       degtorad  = pie / 180.0!! Mask for which cells are active and inactive and 2D latitude grid!       mask(:,:)    = 0        ! Initialize mask so that cells are inactive       clatdeg(:,:) = spval       clondeg(:,:) = spval       do lat = 1, plat         mask(1:nlon(lat),lat)    = 1     ! Active cells         clatdeg(1:nlon(lat),lat) = latdeg(lat) ! Put latitude in 2D array         clondeg(1:nlon(lat),lat) = londeg(1:nlon(lat),lat)       end do!! Send vertices of each grid point! Verticies are ordered as follows: ! 1=lower left, 2 = upper left, 3 = upper right, 4 = lower right!       ns_vert(:,:,:) = spval       ew_vert(:,:,:) = spval!! Longitude vertices!       do lat = 1, plat         ew_vert(1,1,lat)             = (londeg(1,lat) - 360.0 + londeg(nlon(lat),lat))*0.5         ew_vert(1,2:nlon(lat),lat)   = (londeg(1:nlon(lat)-1,lat) + &                                         londeg(2:nlon(lat),lat))*0.5         ew_vert(2,:nlon(lat),lat)    = ew_vert(1,:nlon(lat),lat)  ! Copy lowleft corner to upleft         ew_vert(3,:nlon(lat)-1,lat)  = ew_vert(1,2:nlon(lat),lat)         ew_vert(3,nlon(lat),lat)     = (londeg(nlon(lat),lat) + (360.0 + londeg(1,lat)))*0.5         ew_vert(4,:nlon(lat),lat)    = ew_vert(3,:nlon(lat),lat)  ! Copy lowright corner to upright       end do!! Latitude!       if ( dycore_is('LR') )then         ns_vert(1,:nlon(1),1)         = -90.0 + (latdeg(1) - latdeg(2))*0.5         ns_vert(2,:nlon(plat),plat)   =  90.0 + (latdeg(plat) - latdeg(plat-1))*0.5       else         ns_vert(1,:nlon(1),1)         = -90.0         ns_vert(2,:nlon(plat),plat)   =  90.0       end if       ns_vert(4,:nlon(1),1)       = ns_vert(1,nlon(1),1)        ! Copy lower left to lower right       ns_vert(3,:nlon(plat),plat) = ns_vert(2,nlon(plat),plat)  ! Copy up left to up right       do lat = 2, plat         ns_vert(1,:nlon(lat),lat) = (latdeg(lat) + latdeg(lat-1) )*0.5         ns_vert(4,:nlon(lat),lat) = ns_vert(1,:nlon(lat),lat)       end do       do lat = 1, plat-1         ns_vert(2,:nlon(lat),lat) = (latdeg(lat) + latdeg(lat+1) )*0.5         ns_vert(3,:nlon(lat),lat) = ns_vert(2,:nlon(lat),lat)       end do!! Get area of grid cells (as radians squared)!       area(:,:) = 0.0       do lat = 1, plat         do lon = 1, nlon(lat)           del_phi = sin( ns_vert(2,lon,lat)*degtorad ) - sin( ns_vert(1,lon,lat)*degtorad )           del_theta = ( ew_vert(4,lon,lat) - ew_vert(1,lon,lat) )*degtorad           area(lon,lat) = del_theta*del_phi         end do       end do!! If grid has a pole point (as in Lin-Rood dynamics!      if ( dycore_is('LR') )then         lat = 1         mask(2:nlon(lat),lat) = 0   ! Only active one point on pole         do lon = 1, nlon(lat)           del_phi = -sin( latdeg(lat)*degtorad ) + sin( ns_vert(2,lon,lat)*degtorad )           del_theta = ( ew_vert(4,lon,lat) - ew_vert(1,lon,lat) )*degtorad           area(lon,lat)  = del_theta*del_phi         end do         lat = plat         mask(2:nlon(lat),lat) = 0   ! Only active one point on pole         do lon = 1, nlon(lat)           del_phi =  sin( latdeg(lat)*degtorad ) - sin( ns_vert(1,lon,lat)*degtorad )           del_theta = ( ew_vert(4,lon,lat) - ew_vert(1,lon,lat) )*degtorad           area(lon,lat)  = del_theta*del_phi         end do       end if       if ( abs(sum(area) - 4.0*pie) > 1.e-12 )then         write (6,*) 'CCSM_MSG_SENDGRID: sum of areas on globe does not = 4*pi'         write (6,*) ' sum of areas = ', sum(area)         call endrun       end if!! Send ibuff and grid information to flux coupler.!       call shr_msg_send_i (ibuff  , nibuff     , SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       call shr_msg_send_r (clondeg,  size(clondeg), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       call shr_msg_send_r (clatdeg, size(clatdeg), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       call shr_msg_send_r (ew_vert, size(ew_vert), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       call shr_msg_send_r (ns_vert, size(ns_vert), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       call shr_msg_send_r (area   , size(area), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       call shr_msg_send_i (mask   , size(mask), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2CI)       write(6,*)'(CCSM_MSG_SENDGRID): sent a->d startup msg_id = ',SHR_MSG_TAG_A2CI       call shr_sys_flush(6)    endif  ! end of if-masterproc    return  end subroutine ccsm_msg_sendgrid!===============================================================================  subroutine ccsm_msg_getalb!----------------------------------------------------------------------- ! ! Purpose: ! Send first time of albedo calculation (along with dummy data) to! coupler and get albedos along with snow and ocn/ice fractions back ! ! Method: ! ! Author: Mariana Vertenstein! !-----------------------------------------------------------------------    use comsrf, only: srfflx_state2d,surface_state2d, icefrac, ocnfrac,snowhice,snowhland    use time_manager, only: get_start_date#include <comctl.h>!--------------------------Local Variables------------------------------    integer i,m,n,lat                   ! indices    integer yr, mon, day                ! year, month, day components of cdatecsm    integer cdatecsm,cseccsm            ! current date,sec     integer msgpday                     ! number of send/recv msgs per day#ifdef SPMD    integer :: numperlat         ! number of values per latitude band    integer :: numsend(0:npes-1) ! number of items to be sent    integer :: numrecv           ! number of items to be received    integer :: displs(0:npes-1)  ! displacement array#endif!-----------------------------------------------------------------------!    if (masterproc) then!! Send first time of albedo calculation (along with dummy data) to the flux coupler. !       call get_start_date(yr, mon, day, cseccsm)       cdatecsm = yr*10000 + mon*100 + day       ibuff(:)  = 0       ibuff(4)  = cdatecsm   ! model date (yyyymmdd)       ibuff(5)  = cseccsm    ! elapsed seconds in current day       ibuff(6)  = 0          ! current time step       ibuff(7)  = plon       ! number of model longitudes       ibuff(8)  = plat       ! number of model latitudes       ibuff(9)  = msgpday    ! number of send/recv msgs per day       ibuff(32) = 0          ! albedo calculation time shift       arput(:,:,:) = 1.0e+36       call shr_msg_send_i (ibuff, size(ibuff), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2C)       call shr_msg_send_r (arput, size(arput), SHR_MSG_TID_CPL, SHR_MSG_TAG_A2C)       if (csm_timing) irtc_s = shr_sys_irtc()!     ! Receive merged surface state from flux coupler.!          ibuff(:) = 0       if (csm_timing) irtc_w = shr_sys_irtc()       call shr_msg_recv_i (ibuff, size(ibuff), SHR_MSG_TID_CPL, SHR_MSG_TAG_C2A)       call shr_msg_recv_r (arget, size(arget), SHR_MSG_TID_CPL, SHR_MSG_TAG_C2A)       if (csm_timing) then          irtc_r = shr_sys_irtc()          write(6,9099) irtc_s,'a->d sending'          write(6,9099) irtc_w,'d->a waiting'          write(6,9099) irtc_r,'d->a received'       end if       write(6,*) '(CCSM_MSG_GETALB) recd d->a surface state, msg_id= ',SHR_MSG_TAG_C2A       call shr_sys_flush(6)    endif  ! end of if-masteproc!! Extract the surface state variables and surface type fractions.! NOTE: at the initial time the flux coupler only sends surface ! states, NOT surface fluxes.!#if (defined SPMD)    do n=1,nrcv       do lat=1,plat          arget_buf(:,n,lat) = arget(:,lat,n)       end do    end do    numperlat = plon*nrcv    call compute_gsfactors (numperlat, numrecv, numsend, displs)    if ( masterproc ) then      call mpiscatterv (arget_buf, numsend, displs, mpir8, arget_spmd(1,1,beglat), &                        numrecv, mpir8, 0, mpicom)    else      call mpiscatterv (0.0_r8, numsend, displs, mpir8, arget_spmd(1,1,beglat), &                        numrecv, mpir8, 0, mpicom)    end if    do lat=beglat,endlat       do i=1,plon          srfflx_state2d(lat)%asdir(i)  = arget_spmd(i,7 ,lat) ! Surface state variable          srfflx_state2d(lat)%aldir(i)  = arget_spmd(i,8 ,lat) ! Surface state variable          srfflx_state2d(lat)%asdif(i)  = arget_spmd(i,9 ,lat) ! Surface state variable          srfflx_state2d(lat)%aldif(i)  = arget_spmd(i,10,lat) ! Surface state variable          srfflx_state2d(lat)%ts(i)     = arget_spmd(i,11,lat) ! Surface state variable          snowhland(i,lat)  = arget_spmd(i,12,lat) ! Surface state variable          icefrac(i,lat)= arget_spmd(i,13,lat) ! Surface type fraction          ocnfrac(i,lat)= arget_spmd(i,14,lat) ! Surface type fraction       end do    end do#else     do lat=beglat,endlat       do i=1,plon          srfflx_state2d(lat)%asdir(i)  = arget(i,lat,7 ) ! Surface state variable          srfflx_state2d(lat)%aldir(i)  = arget(i,lat,8 ) ! Surface state variable          srfflx_state2d(lat)%asdif(i)  = arget(i,lat,9 ) ! Surface state variable          srfflx_state2d(lat)%aldif(i)  = arget(i,lat,10) ! Surface state variable          srfflx_state2d(lat)%ts(i)     = arget(i,lat,11) ! Surface state variable          snowhland(i,lat)  = arget(i,lat,12) ! Surface state variable          icefrac(i,lat)= arget(i,lat,13) ! Surface type fraction          ocnfrac(i,lat)= arget(i,lat,14) ! Surface type fraction       end do    end do#endif!! Set snowh over ice to zero since flux coupler only returns snowh over land!    snowhice(:,:) = 0.09099 format('[mp timing]  irtc = ',i20,' ',a)    return  end subroutine ccsm_msg_getalb!===============================================================================  subroutine ccsm_msg_compat( cpl_maj_vers, cpl_min_vers, expect_maj_vers, expect_min_vers )!----------------------------------------------------------------------- ! ! Purpose: ! Checks that the message recieved from the coupler is compatable! with the type of message that I expect to recieve.  ! ! Method: ! If the minor version numbers differ I print a warning message.  If the major! numbers differ I abort since that means that the change is drastic enough that ! I can't run with the differences.! ! Author: Erik Kluzek! !-----------------------arguments---------------------------------------    integer, intent(in) :: cpl_maj_vers    ! major version from coupler initial ibuff array    integer, intent(in) :: cpl_min_vers    ! minor version from coupler initial ibuff array    integer(SHR_KIND_IN), intent(in) :: expect_maj_vers ! major version of the coupler I'm expecting    integer(SHR_KIND_IN), intent(in) :: expect_min_vers ! minor version of the coupler I'm expecting!-----------------------------------------------------------------------    write(6,*)'(CCSM_MSG_COMPAT): This is revision: $Revision: 1.11.2.6 $'    write(6,*)'              Tag: $Name: cam2_0_brnchT_release3 $'    write(6,*)'              of the message compatability interface:'    if ( cpl_min_vers /= expect_min_vers ) then       write(6,*)'WARNING(cpl_compat):: Minor version of coupler messages different than expected: '       write(6,*)'The version of the coupler being used is: ', cpl_min_vers       write(6,*)'The version I expect is:                  ', expect_min_vers    end if    if ( cpl_maj_vers /= expect_maj_vers )then       write(6,*) 'ERROR(cpl_compat):: Major version of coupler messages different than expected: '       write(6,*) 'The version of the coupler being used is: ', cpl_maj_vers       write(6,*) 'The version I expect is:                  ', expect_maj_vers       call endrun    end if    return  end subroutine ccsm_msg_compat!===============================================================================  subroutine ccsm_compat_check_spval( spval, data, string )!----------------------------------------------------------------------- ! ! Purpose: ! Check that the given piece of real data sent from the coupler is valid data ! and not the couplers special data flag.  This ensures that the data! you expect is actually being sent by the coupler.! ! Method: ! ! Author: Erik Kluzek! !-----------------------------------------------------------------------!------------------ Arguments ------------------------------------------    real(r8) , intent(in) ::  spval, data    character, intent(in) ::  string*(*)!-----------------------------------------------------------------------    if ( spval == data )then       write(6,*)'ERROR::( lsm_compat_check_spval) msg incompatibility'       write(6,*)'ERROR:: I expect to recieve the data type: ', string       write(6,*)'from CPL, but all I got was the special data flag'       write(6,*)'coupler must not be sending this data, you are'       write(6,*)'running with an incompatable version of the coupler'       call endrun    end if    return  end subroutine ccsm_compat_check_spval!===============================================================================#endifend module ccsm_msg