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, 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 2770 2010-11-23 15:26:08Z hanke $
00049 ! $Author: hanke $
00050 !
00051    Character(len=len_cvs_string), save :: mycvs = 
00052        '$Id: psmile_deallocate.F90 2770 2010-11-23 15:26:08Z hanke $'
00053 !
00054 !----------------------------------------------------------------------
00055 !
00056 ! ==> Deallocate Component Arrays
00057 
00058 !rr      if (Allocated(comp_infos)) then
00059 !rr        do i = 1, Number_of_Comps_allocated
00060 !rr           if (Associated(comp_infos(i)%Number_of_Grids_Vector)) &
00061 !rr               Deallocate(comp_infos(i)%Number_of_Grids_Vector, STAT=ierr)
00062 !rr           if (Associated(comp_infos(i)%psmile_ranks)) &
00063 !rr               Deallocate(comp_infos(i)%psmile_ranks, STAT=ierr)
00064 !rr           if (Associated(comp_infos(i)%all_extents))  &
00065 !rr               Deallocate(comp_infos(i)%all_extents, STAT=ierr)
00066 !rr        enddo
00067 !rr        Deallocate(comp_infos, STAT=ierr)
00068 !rr      endif
00069 !rr
00070 !rr      if (Associated(Comps)) Deallocate(Comps, STAT=ierr)
00071 
00072      ierror = 0
00073 
00074 ! ==> Deallocate Grid Arrays
00075 
00076      ierr       = 0
00077      error_flag = .false.
00078 
00079      if (Associated(Grids)) then
00080 
00081         do i = 1, Number_of_Grids_allocated
00082            if (Associated(Grids(i)%partition))  &
00083                Deallocate(Grids(i)%partition, STAT=ierr)
00084            if (ierr /= 0) then
00085               error_flag = .true.
00086               ierror = ierr
00087            endif
00088 
00089            if (Associated(Grids(i)%corner_pointer)) then
00090               if (Associated(Grids(i)%corner_pointer%pole_array)) &
00091                   Deallocate(Grids(i)%corner_pointer%pole_array, STAT=ierr)
00092               if (ierr /= 0) then
00093                  error_flag = .true.
00094                  ierror = ierr
00095               endif
00096               if (Associated(Grids(i)%corner_pointer%corners_real(1)%vector)) &
00097                   Deallocate(Grids(i)%corner_pointer%corners_real(1)%vector, STAT=ierr)
00098               if (ierr /= 0) then
00099                  error_flag = .true.
00100                  ierror = ierr
00101               endif
00102               if (Associated(Grids(i)%corner_pointer%corners_real(2)%vector)) &
00103                   Deallocate(Grids(i)%corner_pointer%corners_real(2)%vector, STAT=ierr)
00104               if (ierr /= 0) then
00105                  error_flag = .true.
00106                  ierror = ierr
00107               endif
00108               if (Associated(Grids(i)%corner_pointer%corners_real(3)%vector)) &
00109                   Deallocate(Grids(i)%corner_pointer%corners_real(3)%vector, STAT=ierr)
00110               if (ierr /= 0) then
00111                  error_flag = .true.
00112                  ierror = ierr
00113               endif
00114               if (Associated(Grids(i)%corner_pointer%corners_dble(1)%vector)) &
00115                   Deallocate(Grids(i)%corner_pointer%corners_dble(1)%vector, STAT=ierr)
00116               if (ierr /= 0) then
00117                  error_flag = .true.
00118                  ierror = ierr
00119               endif
00120               if (Associated(Grids(i)%corner_pointer%corners_dble(2)%vector)) &
00121                   Deallocate(Grids(i)%corner_pointer%corners_dble(2)%vector, STAT=ierr)
00122               if (ierr /= 0) then
00123                  error_flag = .true.
00124                  ierror = ierr
00125               endif
00126               if (Associated(Grids(i)%corner_pointer%corners_dble(3)%vector)) &
00127                   Deallocate(Grids(i)%corner_pointer%corners_dble(3)%vector, STAT=ierr)
00128               if (ierr /= 0) then
00129                  error_flag = .true.
00130                  ierror = ierr
00131               endif
00132 #if defined ( PRISM_QUAD_TYPE )
00133               if (Associated(Grids(i)%corner_pointer%corners_quad(1)%vector)) &
00134                   Deallocate(Grids(i)%corner_pointer%corners_quad(1)%vector, STAT=ierr)
00135               if (ierr /= 0) then
00136                  error_flag = .true.
00137                  ierror = ierr
00138               endif
00139               if (Associated(Grids(i)%corner_pointer%corners_quad(2)%vector)) &
00140                   Deallocate(Grids(i)%corner_pointer%corners_quad(2)%vector, STAT=ierr)
00141               if (ierr /= 0) then
00142                  error_flag = .true.
00143                  ierror = ierr
00144               endif
00145               if (Associated(Grids(i)%corner_pointer%corners_quad(3)%vector)) &
00146                   Deallocate(Grids(i)%corner_pointer%corners_quad(3)%vector, STAT=ierr)
00147               if (ierr /= 0) then
00148                  error_flag = .true.
00149                  ierror = ierr
00150               endif
00151 #endif
00152               if (Associated(Grids(i)%star)) &
00153                   Deallocate(Grids(i)%star, STAT=ierr)
00154               if (ierr /= 0) then
00155                  error_flag = .true.
00156                  ierror = ierr
00157               endif
00158               if (Associated(Grids(i)%face)) &
00159                   Deallocate(Grids(i)%face, STAT=ierr)
00160               if (ierr /= 0) then
00161                  error_flag = .true.
00162                  ierror = ierr
00163               endif
00164 
00165               if (Associated(Grids(i)%global_beg)) &
00166                   Deallocate(Grids(i)%global_beg, STAT=ierr)
00167               if (ierr /= 0) then
00168                  error_flag = .true.
00169                  ierror = ierr
00170               endif
00171 
00172               if (Associated(Grids(i)%global_end)) &
00173                   Deallocate(Grids(i)%global_end, STAT=ierr)
00174               if (ierr /= 0) then
00175                  error_flag = .true.
00176                  ierror = ierr
00177               endif
00178 
00179               if (Associated(Grids(i)%g2l)) &
00180                   Deallocate(Grids(i)%g2l, STAT=ierr)
00181               if (ierr /= 0) then
00182                  error_flag = .true.
00183                  ierror = ierr
00184               endif
00185 
00186               if (Associated(Grids(i)%l2g)) &
00187                   Deallocate(Grids(i)%l2g, STAT=ierr)
00188               if (ierr /= 0) then
00189                  error_flag = .true.
00190                  ierror = ierr
00191               endif
00192 
00193               if (Associated(Grids(i)%nbr_points_per_lat)) &
00194                   Deallocate(Grids(i)%nbr_points_per_lat, STAT=ierr)
00195               if (ierr /= 0) then
00196                  error_flag = .true.
00197                  ierror = ierr
00198               endif
00199 
00200               if (Associated(Grids(i)%halo)) &
00201                   Deallocate(Grids(i)%halo, STAT=ierr)
00202               if (ierr /= 0) then
00203                  error_flag = .true.
00204                  ierror = ierr
00205               endif
00206 
00207               Deallocate(Grids(i)%corner_pointer, STAT=ierr)
00208               if (ierr /= 0) then
00209                  error_flag = .true.
00210                  ierror = ierr
00211               endif
00212            endif
00213         enddo
00214 
00215         Deallocate(Grids, STAT=ierr)
00216         if (ierr /= 0) then
00217            error_flag = .true.
00218            ierror = ierr
00219         endif
00220 
00221         if (error_flag) then
00222            ierrp (1) = ierror
00223            ierr = PRISM_Error_Dealloc
00224 
00225            call psmile_error ( ierr, 'Grids pointer', &
00226                 ierrp, 1, __FILE__, __LINE__ )
00227            error_flag = .false.
00228         endif
00229      endif
00230 
00231 ! ==> Deallocate Masks (and vector masks as part of "Masks")
00232 
00233      call psmile_deallocate_masks (ierror)
00234 
00235 ! ==> Deallocate Methods
00236 
00237      call psmile_deallocate_methods (ierror)
00238 
00239 ! ==> Deallocate Fields
00240 
00241      call psmile_deallocate_fields (ierror)
00242 
00243      if ( Associated(cpl_list) ) then
00244          Deallocate (cpl_list, STAT = ierror)
00245          if (ierror > 0) then
00246             ierrp (1) = ierror
00247             ierror = PRISM_Error_Dealloc
00248             call psmile_error ( ierror, 'cpl_list', &
00249                  ierrp, 1, __FILE__, __LINE__ )
00250             return
00251          endif
00252      endif
00253 
00254 ! ==> Deallocate Userdefs
00255 
00256      ierr = 0
00257      error_flag = .false.
00258 
00259      if (Associated(Userdefs)) then
00260 
00261         do i = 1, Number_of_Userdefs_allocated
00262 
00263            if (Associated(Userdefs(i)%iga_igl))  &
00264                Deallocate (Userdefs(i)%iga_igl, STAT=ierr)
00265            if (Associated(Userdefs(i)%dga_wght))  &
00266                Deallocate (Userdefs(i)%dga_wght, STAT=ierr)
00267            if (Associated(Userdefs(i)%real_gridless))  &
00268                Deallocate (Userdefs(i)%real_gridless, STAT=ierr)
00269            if (Associated(Userdefs(i)%dble_gridless))  &
00270                Deallocate (Userdefs(i)%dble_gridless, STAT=ierr)
00271 
00272            if (ierr /= 0) then
00273               error_flag = .true.
00274               ierror = ierr
00275            endif
00276 
00277         enddo
00278 
00279         Deallocate(Userdefs, STAT=ierr)
00280         if (ierr /= 0) then
00281            error_flag = .true.
00282            ierror = ierr
00283         endif
00284 
00285         if (error_flag) then
00286            ierrp (1) = ierror
00287            ierr = PRISM_Error_Dealloc
00288 
00289            call psmile_error ( ierr, 'Userdefs pointer', &
00290                 ierrp, 1, __FILE__, __LINE__ )
00291            error_flag = .false.
00292         endif
00293 
00294      endif
00295 
00296    end subroutine PSMILe_Deallocate
00297 
00298    ! ===========================================================================
00299 
00300    subroutine psmile_deallocate_methods (ierror)
00301 
00302       use psmile, only: methods, number_of_methods_allocated
00303       use prism_constants, only: PRISM_Error_Dealloc
00304 
00305       implicit none
00306 
00307       integer, intent(out) :: ierror
00308 
00309       integer :: ierr
00310       integer :: i, j, k
00311 
00312       ierror = 0
00313       ierr = 0
00314 
00315       if (Associated(Methods)) then
00316 
00317          do i = 1, size (Methods)
00318 
00319 ! ... 1st the points
00320 
00321             if (Associated(Methods(i)%coords_pointer)) then
00322 
00323                do j = 1, 3
00324 
00325                   if (Associated(Methods(i)%coords_pointer%coords_real(j)%vector)) &
00326                         Deallocate(Methods(i)%coords_pointer%coords_real(j)%vector, STAT=ierr)
00327                   if (ierr /= 0) ierror = ierr
00328 
00329                   if (Associated(Methods(i)%coords_pointer%coords_dble(j)%vector)) &
00330                         Deallocate(Methods(i)%coords_pointer%coords_dble(j)%vector, STAT=ierr)
00331                   if (ierr /= 0) ierror = ierr
00332 
00333 #if defined ( PRISM_QUAD_TYPE )
00334                   if (Associated(Methods(i)%coords_pointer%coords_quad(j)%vector)) &
00335                         Deallocate(Methods(i)%coords_pointer%coords_quad(j)%vector, STAT=ierr)
00336                   if (ierr /= 0) ierror = ierr
00337 #endif
00338                enddo ! j = 1, 3
00339 
00340                do j = 1, 2
00341 
00342                   if (Associated(Methods(i)%gauss2_real(j)%vector)) &
00343                         Deallocate(Methods(i)%gauss2_real(j)%vector, STAT=ierr)
00344                   if (ierr /= 0) ierror = ierr
00345 
00346                   if (Associated(Methods(i)%gauss2_dble(j)%vector)) &
00347                         Deallocate(Methods(i)%gauss2_dble(j)%vector, STAT=ierr)
00348                   if (ierr /= 0) ierror = ierr
00349 
00350 #if defined ( PRISM_QUAD_TYPE )
00351                   if (Associated(Methods(i)%gauss2_quad(j)%vector)) &
00352                         Deallocate(Methods(i)%gauss2_quad(j)%vector, STAT=ierr)
00353                   if (ierr /= 0) ierror = ierr
00354 #endif
00355                enddo ! j = 1, 2
00356             endif ! (Associated(Methods(i)%coords_pointer))
00357 
00358 ! ... 2nd the halos
00359 
00360             if (Associated(Methods(i)%halo_pointer)) then
00361 
00362                do j = 1, size(Methods(i)%halo_pointer)
00363 
00364                   do k = 1, 3
00365 
00366                      if ( Associated(Methods(i)%halo_pointer(j)%halo_real(k)%vector) ) &
00367                            Deallocate(Methods(i)%halo_pointer(j)%halo_real(k)%vector, STAT=ierr)
00368                      if (ierr /= 0) ierror = ierr
00369 
00370                      if ( Associated(Methods(i)%halo_pointer(j)%halo_dble(k)%vector) ) &
00371                            Deallocate(Methods(i)%halo_pointer(j)%halo_dble(k)%vector, STAT=ierr)
00372                      if (ierr /= 0) ierror = ierr
00373 
00374 #if defined ( PRISM_QUAD_TYPE )
00375                      if ( Associated(Methods(i)%halo_pointer(j)%halo_quad(k)%vector) ) &
00376                            Deallocate(Methods(i)%halo_pointer(j)%halo_qaus(k)%vector, STAT=ierr)
00377                      if (ierr /= 0) ierror = ierr
00378 #endif
00379                   enddo ! k = 1, 3
00380 
00381                enddo ! j = 1, size(Methods(i)%halo_pointer)
00382 
00383                Deallocate(Methods(i)%halo_pointer, STAT=ierr)
00384                if (ierr /= 0) ierror = ierr
00385 
00386             endif ! (Associated(Methods(i)%halo_pointer))
00387 
00388 ! ... 3rd the subgrids
00389 
00390             if (Associated(Methods(i)%subgrid_pointer)) then
00391 
00392                if (Associated(Methods(i)%subgrid_pointer%subgrid_real)) &
00393                      Deallocate(Methods(i)%subgrid_pointer%subgrid_real, STAT=ierr)
00394                if (ierr /= 0) ierror = ierr
00395 
00396                if (Associated(Methods(i)%subgrid_pointer%subgrid_double)) &
00397                      Deallocate(Methods(i)%subgrid_pointer%subgrid_double, STAT=ierr)
00398                if (ierr /= 0) ierror = ierr
00399 
00400 #if defined ( PRISM_QUAD_TYPE )
00401                if (Associated(Methods(i)%subgrid_pointer%subgrid_quad)) &
00402                      Deallocate(Methods(i)%subgrid_pointer%subgrid_quad, STAT=ierr)
00403                if (ierr /= 0) ierror = ierr
00404 
00405 #endif
00406                Deallocate(Methods(i)%subgrid_pointer, STAT=ierr)
00407                if (ierr /= 0) ierror = ierr
00408 
00409             endif ! (Associated(Methods(i)%subgrid_pointer))
00410 
00411 ! ... 4th the vector points
00412 
00413             if (Associated(Methods(i)%vector_pointer)) &
00414                   Deallocate(Methods(i)%vector_pointer, STAT=ierr)
00415             if (ierr /= 0) ierror = ierr
00416 
00417          enddo ! i = 1, size (Methods)
00418 
00419 ! ... 5th and the Methods itself
00420 
00421          Deallocate(Methods, STAT=ierr)
00422          if (ierr /= 0) ierror = ierr
00423 
00424          if (ierror /= 0) then
00425             call psmile_error ( PRISM_Error_Dealloc, 'Methods pointer', &
00426                   (/ierror/), 1, __FILE__, __LINE__ )
00427          endif
00428 
00429       endif ! (Associated(Methods))
00430 
00431       nullify (Methods)
00432       number_of_methods_allocated = 0
00433 
00434    end subroutine psmile_deallocate_methods
00435 
00436    ! ===========================================================================
00437 
00438    !TODO: this routine is incomplete. for example it does not deallocate
00439    !      send/recv_information in taskout_type
00440    subroutine psmile_deallocate_fields (ierror)
00441 
00442       use psmile, only: Fields, number_of_fields_allocated
00443       use prism_constants, only: PRISM_Error_Dealloc
00444 
00445       implicit none
00446 
00447       integer, intent(out) :: ierror
00448 
00449       integer :: ierr
00450       integer :: i, j
00451 
00452       ierror = 0
00453       ierr = 0
00454 
00455       if (Associated(Fields)) then
00456 
00457          do i = 1, size (Fields)
00458 
00459             if (Associated(Fields(i)%Taskout)) then
00460 
00461                do j = 1, size(Fields(i)%Taskout)
00462 
00463                   if ( Associated(Fields(i)%Taskout(j)%buffer_int) ) &
00464                      Deallocate(Fields(i)%Taskout(j)%buffer_int, STAT=ierr )
00465                   if (ierr /= 0) ierror = ierr
00466                   if ( Associated(Fields(i)%Taskout(j)%buffer_real)) &
00467                      Deallocate(Fields(i)%Taskout(j)%buffer_real, STAT=ierr )
00468                   if (ierr /= 0) ierror = ierr
00469                   if ( Associated(Fields(i)%Taskout(j)%buffer_dble)) &
00470                      Deallocate(Fields(i)%Taskout(j)%buffer_dble, STAT=ierr )
00471                   if (ierr /= 0) ierror = ierr
00472 #if defined ( PRISM_QUAD_TYPE )
00473                   if ( Associated(Fields(i)%Taskout(j)%buffer_quad)) &
00474                      Deallocate(Fields(i)%Taskout(j)%buffer_quad, STAT=ierr )
00475                   if (ierr /= 0) ierror = ierr
00476 #endif
00477                   if ( Associated(Fields(i)%Taskout(j)%Judate_Axis)) &
00478                      Deallocate(Fields(i)%Taskout(j)%Judate_Axis, STAT=ierr )
00479                   if (ierr /= 0) ierror = ierr
00480 
00481                enddo ! j = 1, size(Fields(i)%Taskout)
00482 
00483                Deallocate(Fields(i)%Taskout, STAT=ierr)
00484                if (ierr /= 0) ierror = ierr
00485 
00486             endif ! (Associated(Fields(i)%Taskout))
00487 
00488             if ( Associated(Fields(i)%Taskin%buffer_int) ) &
00489                   Deallocate(Fields(i)%Taskin%buffer_int, STAT=ierr )
00490             if (ierr /= 0) ierror = ierr
00491             if ( Associated(Fields(i)%Taskin%buffer_real)) &
00492                   Deallocate(Fields(i)%Taskin%buffer_real, STAT=ierr )
00493             if (ierr /= 0) ierror = ierr
00494             if ( Associated(Fields(i)%Taskin%buffer_dble)) &
00495                   Deallocate(Fields(i)%Taskin%buffer_dble, STAT=ierr )
00496             if (ierr /= 0) ierror = ierr
00497 #if defined ( PRISM_QUAD_TYPE )
00498             if ( Associated(Fields(i)%Taskin%buffer_quad)) &
00499                   Deallocate(Fields(i)%Taskin%buffer_quad, STAT=ierr )
00500             if (ierr /= 0) ierror = ierr
00501 #endif
00502             if ( Associated(Fields(i)%Taskin%Judate_Axis)) &
00503                   Deallocate(Fields(i)%Taskin%Judate_Axis, STAT=ierr )
00504             if (ierr /= 0) ierror = ierr
00505 
00506             if ( Associated(Fields(i)%Taskin%In_channel)) &
00507                   Deallocate(Fields(i)%Taskin%In_channel, STAT=ierr )
00508             if (ierr /= 0) ierror = ierr
00509 
00510          enddo ! i = 1, Number_of_Fields_allocated
00511 
00512          Deallocate(Fields, STAT=ierr)
00513          if (ierr /= 0) ierror = ierr
00514 
00515          if (ierror /= 0) then
00516             call psmile_error ( PRISM_Error_Dealloc, 'Fields pointer', &
00517                   (/ierror/), 1, __FILE__, __LINE__ )
00518          endif
00519 
00520       endif ! (Associated(Fields))
00521 
00522       nullify (Fields)
00523       number_of_fields_allocated = 0
00524 
00525    end subroutine psmile_deallocate_fields
00526 
00527    ! ===========================================================================
00528 
00529    subroutine psmile_deallocate_masks (ierror)
00530 
00531       use psmile, only: Masks, number_of_masks_allocated
00532       use prism_constants, only: PRISM_Error_Dealloc
00533 
00534       implicit none
00535 
00536       integer, intent(out) :: ierror
00537 
00538       integer :: ierr
00539       integer :: i
00540 
00541       ierror = 0
00542       ierr = 0
00543 
00544       if (Associated(Masks)) then
00545          do i = 1, size (Masks)
00546             if (Associated(Masks(i)%mask_array)) &
00547                   Deallocate(Masks(i)%mask_array, STAT=ierr)
00548             if (ierr /= 0) ierror = ierr
00549 
00550             if (ierror /= 0) then
00551                call psmile_error ( PRISM_Error_Dealloc, 'Mask Array', &
00552                      (/ierror/), 1, __FILE__, __LINE__ )
00553             endif
00554          enddo
00555 
00556          Deallocate(Masks, STAT=ierr)
00557          if (ierr /= 0) ierror = ierr
00558 
00559          if (ierror /= 0) then
00560             call psmile_error ( PRISM_Error_Dealloc, 'Masks pointer', &
00561                   (/ierror/), 1, __FILE__, __LINE__ )
00562          endif
00563       endif
00564 
00565       nullify (Masks)
00566       number_of_masks_allocated = 0
00567 
00568    end subroutine psmile_deallocate_masks