psmile_store_mask_locs_3d.F90

Go to the documentation of this file.
00001     subroutine psmile_store_mask_locs_3d ( ipart, range,  control,  found,  & 
00002                                            send_info, nprev, ncpl, ierror )
00003        use PRISM_constants
00004 
00005        use PSMILe, dummy_interface => psmile_store_mask_locs_3d
00006 
00007        Implicit none
00008 
00009        Integer, Intent(In)                   :: ipart
00010        Integer, Intent(In)                   :: range  (2,ndim_3d)
00011        Integer, Intent(In)                   :: control(2,ndim_3d)
00012        Integer, Intent(In)                   :: found ( range(1,1):range(2,1), 
00013                                                         range(1,2):range(2,2), 
00014                                                         range(1,3):range(2,3))
00015        Type(Send_information), Intent(InOut) :: send_info
00016        Integer, Intent(In)                   :: nprev
00017        Integer, Intent(In)                   :: ncpl
00018 
00019        Integer, Intent(Out)                  :: ierror
00020 
00021        Integer :: ii, jj, kk, n
00022 !
00023 !     ... for error handling
00024 !
00025       Integer, parameter              :: nerrp = 2
00026       Integer                         :: ierrp (nerrp)
00027 !
00028 !  Initialization
00029 !
00030 #ifdef VERBOSE
00031        print 9990, trim(ch_id), nprev, ncpl
00032 
00033        call psmile_flushstd
00034 #endif /* VERBOSE */
00035 
00036        ierror = 0
00037 !
00038 ! Horizontal dimension
00039 !
00040        if ( nprev == 0 ) then
00041           Allocate (send_info%msklocs(1,1)%vector(ncpl), STAT = ierror)
00042 
00043           if ( ierror > 0 ) then
00044              ierrp (1) = ierror
00045              ierrp (2) = ncpl
00046              ierror = PRISM_Error_Alloc
00047              call psmile_error ( ierror, 'send_info%msklocs%vector', &
00048                   ierrp, 2, __FILE__, __LINE__ )
00049              return
00050           endif
00051        endif
00052 
00053        n = nprev
00054 
00055        do kk = range(1,3), range(2,3)
00056           do jj = range(1,2), range(2,2)
00057              do ii = range(1,1), range(2,1)
00058                 if (abs(found(ii,jj,kk)) == 1 .or. found(ii,jj,kk) == 0 ) then
00059                    n = n + 1
00060                    if ( ii >= control(1,1) .and. ii <=  control(2,1) .and. &
00061                         jj >= control(1,2) .and. jj <=  control(2,2) .and. &
00062                         kk >= control(1,3) .and. kk <=  control(2,3) ) then
00063                       send_info%msklocs(1,1)%vector(n) = .true.
00064                    else
00065                       send_info%msklocs(1,1)%vector(n) = .false.
00066                    endif
00067                 endif
00068              end do
00069           end do
00070        end do
00071 !
00072 !===> All done
00073 !
00074 #ifdef VERBOSE
00075       print 9980, trim(ch_id), ierror
00076 
00077       call psmile_flushstd
00078 #endif /* VERBOSE */
00079 !
00080 !  Formats:
00081 !
00082 #ifdef VERBOSE
00083 
00084 9990 format (1x, a, ': psmile_store_mask_locs_3d: nprev ', i8, ' ncpl ', i8)
00085 
00086 9980 format (1x, a, ': psmile_store_mask_locs_3d: eof ierror =', i3)
00087 
00088 #endif /* VERBOSE */
00089 
00090      end subroutine psmile_store_mask_locs_3d