psmile_deallocate.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2006-2010, NEC Europe Ltd., London, UK.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !BOP
00006 !
00007 ! !ROUTINE: PSMILe_Deallocate
00008 !
00009 ! !INTERFACE:
00010 
00011    subroutine psmile_deallocate ( ierror )
00012 !
00013 ! !USES:
00014 !
00015       use PRISM_constants
00016 !
00017       use PSMILe, dummy_interface => PSMILe_Deallocate
00018 !
00019       implicit none
00020 !
00021 ! !OUTUT PARAMETERS:
00022 !
00023      integer, intent(out) :: ierror
00024 
00025 !    returned error code
00026 !
00027 ! !LOCAL VARIABLES
00028 !
00029      integer :: i, ii, j, ierr
00030      logical :: error_flag
00031      integer, parameter :: nerrp = 1
00032      integer :: ierrp(nerrp)
00033 !
00034 ! !DESCRIPTION:
00035 !
00036 ! Subroutine "PSMILe_Deallocate" deallocates all PSMILe local memory
00037 !
00038 !
00039 ! !REVISION HISTORY:
00040 !
00041 !   Date      Programmer    Description
00042 ! ----------  -----------   -----------
00043 ! 03.06.03    R. Redler     created
00044 !
00045 !EOP
00046 !----------------------------------------------------------------------
00047 !
00048 ! $Id: psmile_deallocate.F90 3248 2011-06-23 13:03:19Z coquart $
00049 ! $Author: coquart $
00050 !
00051    Character(len=len_cvs_string), save :: mycvs = 
00052        '$Id: psmile_deallocate.F90 3248 2011-06-23 13:03:19Z coquart $'
00053 !
00054 !----------------------------------------------------------------------
00055 !
00056      ierror = 0
00057 
00058 ! ==> Deallocate Grid Arrays
00059 
00060      ierr       = 0
00061      error_flag = .false.
00062 
00063      if (Associated(Grids)) then
00064 
00065         do i = 1, Number_of_Grids_allocated
00066            if (Associated(Grids(i)%partition))  &
00067                Deallocate(Grids(i)%partition, STAT=ierr)
00068            if (ierr /= 0) then
00069               error_flag = .true.
00070               ierror = ierr
00071            endif
00072 
00073            if (Associated(Grids(i)%corner_pointer)) then
00074               if (Associated(Grids(i)%corner_pointer%pole_array)) &
00075                   Deallocate(Grids(i)%corner_pointer%pole_array, STAT=ierr)
00076               if (ierr /= 0) then
00077                  error_flag = .true.
00078                  ierror = ierr
00079               endif
00080               if (Associated(Grids(i)%corner_pointer%corners_real(1)%vector)) &
00081                   Deallocate(Grids(i)%corner_pointer%corners_real(1)%vector, STAT=ierr)
00082               if (ierr /= 0) then
00083                  error_flag = .true.
00084                  ierror = ierr
00085               endif
00086               if (Associated(Grids(i)%corner_pointer%corners_real(2)%vector)) &
00087                   Deallocate(Grids(i)%corner_pointer%corners_real(2)%vector, STAT=ierr)
00088               if (ierr /= 0) then
00089                  error_flag = .true.
00090                  ierror = ierr
00091               endif
00092               if (Associated(Grids(i)%corner_pointer%corners_real(3)%vector)) &
00093                   Deallocate(Grids(i)%corner_pointer%corners_real(3)%vector, STAT=ierr)
00094               if (ierr /= 0) then
00095                  error_flag = .true.
00096                  ierror = ierr
00097               endif
00098               if (Associated(Grids(i)%corner_pointer%corners_dble(1)%vector)) &
00099                   Deallocate(Grids(i)%corner_pointer%corners_dble(1)%vector, STAT=ierr)
00100               if (ierr /= 0) then
00101                  error_flag = .true.
00102                  ierror = ierr
00103               endif
00104               if (Associated(Grids(i)%corner_pointer%corners_dble(2)%vector)) &
00105                   Deallocate(Grids(i)%corner_pointer%corners_dble(2)%vector, STAT=ierr)
00106               if (ierr /= 0) then
00107                  error_flag = .true.
00108                  ierror = ierr
00109               endif
00110               if (Associated(Grids(i)%corner_pointer%corners_dble(3)%vector)) &
00111                   Deallocate(Grids(i)%corner_pointer%corners_dble(3)%vector, STAT=ierr)
00112               if (ierr /= 0) then
00113                  error_flag = .true.
00114                  ierror = ierr
00115               endif
00116 #if defined ( PRISM_QUAD_TYPE )
00117               if (Associated(Grids(i)%corner_pointer%corners_quad(1)%vector)) &
00118                   Deallocate(Grids(i)%corner_pointer%corners_quad(1)%vector, STAT=ierr)
00119               if (ierr /= 0) then
00120                  error_flag = .true.
00121                  ierror = ierr
00122               endif
00123               if (Associated(Grids(i)%corner_pointer%corners_quad(2)%vector)) &
00124                   Deallocate(Grids(i)%corner_pointer%corners_quad(2)%vector, STAT=ierr)
00125               if (ierr /= 0) then
00126                  error_flag = .true.
00127                  ierror = ierr
00128               endif
00129               if (Associated(Grids(i)%corner_pointer%corners_quad(3)%vector)) &
00130                   Deallocate(Grids(i)%corner_pointer%corners_quad(3)%vector, STAT=ierr)
00131               if (ierr /= 0) then
00132                  error_flag = .true.
00133                  ierror = ierr
00134               endif
00135 #endif
00136 
00137               if (Associated(Grids(i)%reduced_gauss_data%nbr_points_per_lat)) &
00138                   Deallocate(Grids(i)%reduced_gauss_data%nbr_points_per_lat, STAT=ierr)
00139               if (ierr /= 0) then
00140                  error_flag = .true.
00141                  ierror = ierr
00142               endif
00143 
00144               if (Associated(Grids(i)%reduced_gauss_data%aux_3d_to_local_1d_map)) &
00145                   Deallocate(Grids(i)%reduced_gauss_data%aux_3d_to_local_1d_map, STAT=ierr)
00146               if (ierr /= 0) then
00147                  error_flag = .true.
00148                  ierror = ierr
00149               endif
00150 
00151               if (Associated(Grids(i)%reduced_gauss_data%local_1d_stencil_lookup)) &
00152                   Deallocate(Grids(i)%reduced_gauss_data%local_1d_stencil_lookup, STAT=ierr)
00153               if (ierr /= 0) then
00154                  error_flag = .true.
00155                  ierror = ierr
00156               endif
00157 
00158               if (Associated(Grids(i)%reduced_gauss_data%local_block_info)) &
00159                   Deallocate(Grids(i)%reduced_gauss_data%local_block_info, STAT=ierr)
00160               if (ierr /= 0) then
00161                  error_flag = .true.
00162                  ierror = ierr
00163               endif
00164 
00165               if (Associated(Grids(i)%reduced_gauss_data%global_lat_offsets)) &
00166                   Deallocate(Grids(i)%reduced_gauss_data%global_lat_offsets, STAT=ierr)
00167               if (ierr /= 0) then
00168                  error_flag = .true.
00169                  ierror = ierr
00170               endif
00171 
00172               do j = 1, ndim_3d
00173                  if (Associated(Grids(i)%reduced_gauss_data%aux_corners(j)%vector)) &
00174                      Deallocate(Grids(i)%reduced_gauss_data%aux_corners(j)%vector, STAT=ierr)
00175                  if (ierr /= 0) then
00176                     error_flag = .true.
00177                     ierror = ierr
00178                  endif
00179               enddo
00180 
00181               if (Associated(Grids(i)%halo)) &
00182                   Deallocate(Grids(i)%halo, STAT=ierr)
00183               if (ierr /= 0) then
00184                  error_flag = .true.
00185                  ierror = ierr
00186               endif
00187 
00188               Deallocate(Grids(i)%corner_pointer, STAT=ierr)
00189               if (ierr /= 0) then
00190                  error_flag = .true.
00191                  ierror = ierr
00192               endif
00193            endif
00194         enddo
00195 
00196         Deallocate(Grids, STAT=ierr)
00197         if (ierr /= 0) then
00198            error_flag = .true.
00199            ierror = ierr
00200         endif
00201 
00202         if (error_flag) then
00203            ierrp (1) = ierror
00204            ierr = PRISM_Error_Dealloc
00205 
00206            call psmile_error ( ierr, 'Grids pointer', &
00207                 ierrp, 1, __FILE__, __LINE__ )
00208            error_flag = .false.
00209         endif
00210      endif
00211 
00212 ! ==> Deallocate Masks (and vector masks as part of "Masks")
00213 
00214      call psmile_deallocate_masks (ierror)
00215 
00216 ! ==> Deallocate Methods
00217 
00218      call psmile_deallocate_methods (ierror)
00219 
00220 ! ==> Deallocate Fields
00221 
00222      call psmile_deallocate_fields (ierror)
00223 
00224      if ( Associated(cpl_list) ) then
00225          Deallocate (cpl_list, STAT = ierror)
00226          if (ierror > 0) then
00227             ierrp (1) = ierror
00228             ierror = PRISM_Error_Dealloc
00229             call psmile_error ( ierror, 'cpl_list', &
00230                  ierrp, 1, __FILE__, __LINE__ )
00231             return
00232          endif
00233      endif
00234 
00235 ! ==> Deallocate Userdefs
00236 
00237      ierr = 0
00238      error_flag = .false.
00239 
00240      if (Associated(Userdefs)) then
00241 
00242         do i = 1, Number_of_Userdefs_allocated
00243 
00244            if (Associated(Userdefs(i)%iga_igl))  &
00245                Deallocate (Userdefs(i)%iga_igl, STAT=ierr)
00246            if (Associated(Userdefs(i)%dga_wght))  &
00247                Deallocate (Userdefs(i)%dga_wght, STAT=ierr)
00248            if (Associated(Userdefs(i)%real_gridless))  &
00249                Deallocate (Userdefs(i)%real_gridless, STAT=ierr)
00250            if (Associated(Userdefs(i)%dble_gridless))  &
00251                Deallocate (Userdefs(i)%dble_gridless, STAT=ierr)
00252 
00253            if (ierr /= 0) then
00254               error_flag = .true.
00255               ierror = ierr
00256            endif
00257 
00258         enddo
00259 
00260         Deallocate(Userdefs, STAT=ierr)
00261         if (ierr /= 0) then
00262            error_flag = .true.
00263            ierror = ierr
00264         endif
00265 
00266         if (error_flag) then
00267            ierrp (1) = ierror
00268            ierr = PRISM_Error_Dealloc
00269 
00270            call psmile_error ( ierr, 'Userdefs pointer', &
00271                 ierrp, 1, __FILE__, __LINE__ )
00272            error_flag = .false.
00273         endif
00274 
00275      endif
00276 
00277    end subroutine PSMILe_Deallocate
00278 
00279    ! ===========================================================================
00280 
00281    subroutine psmile_deallocate_methods (ierror)
00282 
00283       use psmile, only: methods, number_of_methods_allocated
00284       use prism_constants, only: PRISM_Error_Dealloc
00285 
00286       implicit none
00287 
00288       integer, intent(out) :: ierror
00289 
00290       integer :: ierr
00291       integer :: i, j, k
00292 
00293       ierror = 0
00294       ierr = 0
00295 
00296       if (Associated(Methods)) then
00297 
00298          do i = 1, size (Methods)
00299 
00300 ! ... 1st the points
00301 
00302             if (Associated(Methods(i)%coords_pointer)) then
00303 
00304                do j = 1, 3
00305 
00306                   if (Associated(Methods(i)%coords_pointer%coords_real(j)%vector)) &
00307                         Deallocate(Methods(i)%coords_pointer%coords_real(j)%vector, STAT=ierr)
00308                   if (ierr /= 0) ierror = ierr
00309 
00310                   if (Associated(Methods(i)%coords_pointer%coords_dble(j)%vector)) &
00311                         Deallocate(Methods(i)%coords_pointer%coords_dble(j)%vector, STAT=ierr)
00312                   if (ierr /= 0) ierror = ierr
00313 
00314 #if defined ( PRISM_QUAD_TYPE )
00315                   if (Associated(Methods(i)%coords_pointer%coords_quad(j)%vector)) &
00316                         Deallocate(Methods(i)%coords_pointer%coords_quad(j)%vector, STAT=ierr)
00317                   if (ierr /= 0) ierror = ierr
00318 #endif
00319                enddo ! j = 1, 3
00320 
00321                do j = 1, 2
00322 
00323                   if (Associated(Methods(i)%gauss2_real(j)%vector)) &
00324                         Deallocate(Methods(i)%gauss2_real(j)%vector, STAT=ierr)
00325                   if (ierr /= 0) ierror = ierr
00326 
00327                   if (Associated(Methods(i)%gauss2_dble(j)%vector)) &
00328                         Deallocate(Methods(i)%gauss2_dble(j)%vector, STAT=ierr)
00329                   if (ierr /= 0) ierror = ierr
00330 
00331 #if defined ( PRISM_QUAD_TYPE )
00332                   if (Associated(Methods(i)%gauss2_quad(j)%vector)) &
00333                         Deallocate(Methods(i)%gauss2_quad(j)%vector, STAT=ierr)
00334                   if (ierr /= 0) ierror = ierr
00335 #endif
00336                enddo ! j = 1, 2
00337             endif ! (Associated(Methods(i)%coords_pointer))
00338 
00339 ! ... 2nd the halos
00340 
00341             if (Associated(Methods(i)%halo_pointer)) then
00342 
00343                do j = 1, size(Methods(i)%halo_pointer)
00344 
00345                   do k = 1, 3
00346 
00347                      if ( Associated(Methods(i)%halo_pointer(j)%halo_real(k)%vector) ) &
00348                            Deallocate(Methods(i)%halo_pointer(j)%halo_real(k)%vector, STAT=ierr)
00349                      if (ierr /= 0) ierror = ierr
00350 
00351                      if ( Associated(Methods(i)%halo_pointer(j)%halo_dble(k)%vector) ) &
00352                            Deallocate(Methods(i)%halo_pointer(j)%halo_dble(k)%vector, STAT=ierr)
00353                      if (ierr /= 0) ierror = ierr
00354 
00355 #if defined ( PRISM_QUAD_TYPE )
00356                      if ( Associated(Methods(i)%halo_pointer(j)%halo_quad(k)%vector) ) &
00357                            Deallocate(Methods(i)%halo_pointer(j)%halo_qaus(k)%vector, STAT=ierr)
00358                      if (ierr /= 0) ierror = ierr
00359 #endif
00360                   enddo ! k = 1, 3
00361 
00362                enddo ! j = 1, size(Methods(i)%halo_pointer)
00363 
00364                Deallocate(Methods(i)%halo_pointer, STAT=ierr)
00365                if (ierr /= 0) ierror = ierr
00366 
00367             endif ! (Associated(Methods(i)%halo_pointer))
00368 
00369 ! ... 3rd the subgrids
00370 
00371             if (Associated(Methods(i)%subgrid_pointer)) then
00372 
00373                if (Associated(Methods(i)%subgrid_pointer%subgrid_real)) &
00374                      Deallocate(Methods(i)%subgrid_pointer%subgrid_real, STAT=ierr)
00375                if (ierr /= 0) ierror = ierr
00376 
00377                if (Associated(Methods(i)%subgrid_pointer%subgrid_double)) &
00378                      Deallocate(Methods(i)%subgrid_pointer%subgrid_double, STAT=ierr)
00379                if (ierr /= 0) ierror = ierr
00380 
00381 #if defined ( PRISM_QUAD_TYPE )
00382                if (Associated(Methods(i)%subgrid_pointer%subgrid_quad)) &
00383                      Deallocate(Methods(i)%subgrid_pointer%subgrid_quad, STAT=ierr)
00384                if (ierr /= 0) ierror = ierr
00385 
00386 #endif
00387                Deallocate(Methods(i)%subgrid_pointer, STAT=ierr)
00388                if (ierr /= 0) ierror = ierr
00389 
00390             endif ! (Associated(Methods(i)%subgrid_pointer))
00391 
00392 ! ... 4th the vector points
00393 
00394             if (Associated(Methods(i)%vector_pointer)) &
00395                   Deallocate(Methods(i)%vector_pointer, STAT=ierr)
00396             if (ierr /= 0) ierror = ierr
00397 
00398          enddo ! i = 1, size (Methods)
00399 
00400 ! ... 5th and the Methods itself
00401 
00402          Deallocate(Methods, STAT=ierr)
00403          if (ierr /= 0) ierror = ierr
00404 
00405          if (ierror /= 0) then
00406             call psmile_error ( PRISM_Error_Dealloc, 'Methods pointer', &
00407                   (/ierror/), 1, __FILE__, __LINE__ )
00408          endif
00409 
00410       endif ! (Associated(Methods))
00411 
00412       nullify (Methods)
00413       number_of_methods_allocated = 0
00414 
00415    end subroutine psmile_deallocate_methods
00416 
00417    ! ===========================================================================
00418 
00419    !TODO: this routine is incomplete. for example it does not deallocate
00420    !      send/recv_information in taskout_type
00421    subroutine psmile_deallocate_fields (ierror)
00422 
00423       use psmile, only: Fields, number_of_fields_allocated
00424       use prism_constants, only: PRISM_Error_Dealloc
00425 
00426       implicit none
00427 
00428       integer, intent(out) :: ierror
00429 
00430       integer :: ierr
00431       integer :: i, j
00432 
00433       ierror = 0
00434       ierr = 0
00435 
00436       if (Associated(Fields)) then
00437 
00438          do i = 1, size (Fields)
00439 
00440             if (Associated(Fields(i)%Taskout)) then
00441 
00442                do j = 1, size(Fields(i)%Taskout)
00443 
00444                   if ( Associated(Fields(i)%Taskout(j)%buffer_int) ) &
00445                      Deallocate(Fields(i)%Taskout(j)%buffer_int, STAT=ierr )
00446                   if (ierr /= 0) ierror = ierr
00447                   if ( Associated(Fields(i)%Taskout(j)%buffer_real)) &
00448                      Deallocate(Fields(i)%Taskout(j)%buffer_real, STAT=ierr )
00449                   if (ierr /= 0) ierror = ierr
00450                   if ( Associated(Fields(i)%Taskout(j)%buffer_dble)) &
00451                      Deallocate(Fields(i)%Taskout(j)%buffer_dble, STAT=ierr )
00452                   if (ierr /= 0) ierror = ierr
00453 #if defined ( PRISM_QUAD_TYPE )
00454                   if ( Associated(Fields(i)%Taskout(j)%buffer_quad)) &
00455                      Deallocate(Fields(i)%Taskout(j)%buffer_quad, STAT=ierr )
00456                   if (ierr /= 0) ierror = ierr
00457 #endif
00458                enddo ! j = 1, size(Fields(i)%Taskout)
00459 
00460                Deallocate(Fields(i)%Taskout, STAT=ierr)
00461                if (ierr /= 0) ierror = ierr
00462 
00463             endif ! (Associated(Fields(i)%Taskout))
00464 
00465             if ( Associated(Fields(i)%Taskin%buffer_int) ) &
00466                   Deallocate(Fields(i)%Taskin%buffer_int, STAT=ierr )
00467             if (ierr /= 0) ierror = ierr
00468             if ( Associated(Fields(i)%Taskin%buffer_real)) &
00469                   Deallocate(Fields(i)%Taskin%buffer_real, STAT=ierr )
00470             if (ierr /= 0) ierror = ierr
00471             if ( Associated(Fields(i)%Taskin%buffer_dble)) &
00472                   Deallocate(Fields(i)%Taskin%buffer_dble, STAT=ierr )
00473             if (ierr /= 0) ierror = ierr
00474 #if defined ( PRISM_QUAD_TYPE )
00475             if ( Associated(Fields(i)%Taskin%buffer_quad)) &
00476                   Deallocate(Fields(i)%Taskin%buffer_quad, STAT=ierr )
00477             if (ierr /= 0) ierror = ierr
00478 #endif
00479             if ( Associated(Fields(i)%Taskin%In_channel)) &
00480                   Deallocate(Fields(i)%Taskin%In_channel, STAT=ierr )
00481             if (ierr /= 0) ierror = ierr
00482 
00483          enddo ! i = 1, Number_of_Fields_allocated
00484 
00485          Deallocate(Fields, STAT=ierr)
00486          if (ierr /= 0) ierror = ierr
00487 
00488          if (ierror /= 0) then
00489             call psmile_error ( PRISM_Error_Dealloc, 'Fields pointer', &
00490                   (/ierror/), 1, __FILE__, __LINE__ )
00491          endif
00492 
00493       endif ! (Associated(Fields))
00494 
00495       nullify (Fields)
00496       number_of_fields_allocated = 0
00497 
00498    end subroutine psmile_deallocate_fields
00499 
00500    ! ===========================================================================
00501 
00502    subroutine psmile_deallocate_masks (ierror)
00503 
00504       use psmile, only: Masks, number_of_masks_allocated
00505       use prism_constants, only: PRISM_Error_Dealloc
00506 
00507       implicit none
00508 
00509       integer, intent(out) :: ierror
00510 
00511       integer :: ierr
00512       integer :: i
00513 
00514       ierror = 0
00515       ierr = 0
00516 
00517       if (Associated(Masks)) then
00518          do i = 1, size (Masks)
00519             if (Associated(Masks(i)%mask_array)) &
00520                   Deallocate(Masks(i)%mask_array, STAT=ierr)
00521             if (ierr /= 0) ierror = ierr
00522 
00523             if (ierror /= 0) then
00524                call psmile_error ( PRISM_Error_Dealloc, 'Mask Array', &
00525                      (/ierror/), 1, __FILE__, __LINE__ )
00526             endif
00527          enddo
00528 
00529          Deallocate(Masks, STAT=ierr)
00530          if (ierr /= 0) ierror = ierr
00531 
00532          if (ierror /= 0) then
00533             call psmile_error ( PRISM_Error_Dealloc, 'Masks pointer', &
00534                   (/ierror/), 1, __FILE__, __LINE__ )
00535          endif
00536       endif
00537 
00538       nullify (Masks)
00539       number_of_masks_allocated = 0
00540 
00541    end subroutine psmile_deallocate_masks