psmile_reallocate.F90

Go to the documentation of this file.
00001 !-----------------------------------------------------------------------
00002 ! Copyright 2010, DKRZ, Hamburg, Germany.
00003 ! All rights reserved. Use is subject to OASIS4 license terms.
00004 !-----------------------------------------------------------------------
00005 !
00006 ! !DESCRIPTION:
00007 !
00008 ! Module psmile_reallocate contains a C-Like realloc function for dble,
00009 ! real, and int arrays
00010 ! based on code taken from http://www.star.le.ac.uk/~cgp/f90course/f90.html
00011 ! REMARK:
00012 ! For derived data types only a shallow copying is done.
00013 !
00014 !
00015 ! !REVISION HISTORY:
00016 !
00017 !   Date      Programmer   Description
00018 ! ----------  ----------   -----------
00019 ! 13.09.10    M. Hanke     created
00020 !
00021 !----------------------------------------------------------------------
00022 !
00023 !  $Id: psmile_reallocate.F90 2762 2010-11-22 16:09:27Z hanke $
00024 !  $Author: hanke $
00025 !
00026 !----------------------------------------------------------------------
00027 
00028 module psmile_reallocate
00029 
00030    use prism_constants, only : PRISM_Error_Alloc, PRISM_Error_Dealloc
00031    use psmile, only : psmile_error, send_information, &
00032                       recv_information, send_appl_information, &
00033                       send_field_information, recv_field_information, &
00034                       ch_ptr, psmile_time_struct
00035    use psmile_user_data, only : user_grid_data, user_point_data, &
00036                                 user_mask_data, user_var_data
00037 
00038    implicit none
00039 
00040    private ! by default everything is private in this module
00041 
00042    interface psmile_realloc
00043       module procedure psmile_reallocate_dble, &
00044                        psmile_reallocate_real, &
00045                        psmile_reallocate_int,  &
00046                        psmile_reallocate_log,  &
00047                        psmile_reallocate_si,   &
00048                        psmile_reallocate_ri,   &
00049                        psmile_reallocate_sai,  &
00050                        psmile_reallocate_sfi,  &
00051                        psmile_reallocate_rfi,  &
00052                        psmile_reallocate_ugd,  &
00053                        psmile_reallocate_upd,  &
00054                        psmile_reallocate_umd,  &
00055                        psmile_reallocate_uvd,  &
00056                        psmile_reallocate_cp,  &
00057                        psmile_reallocate_ts
00058 
00059    end interface
00060 
00061    public :: psmile_realloc
00062 
00063    contains
00064 
00065       function psmile_reallocate_dble(p, n)
00066          double precision, pointer, dimension(:) :: p, psmile_reallocate_dble
00067          integer, intent(in) :: n
00068          integer :: nold
00069          integer, parameter :: nerrp = 2
00070          integer :: ierror, ierrp (nerrp)
00071 
00072          allocate(psmile_reallocate_dble(1:n), stat=ierror)
00073 
00074          if (ierror > 0) then
00075             ierrp (1) = ierror
00076             ierrp (2) = n
00077             ierror = PRISM_Error_Alloc
00078 
00079             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00080                   ierrp, 2, __FILE__, __LINE__ )
00081             return
00082          endif
00083 
00084          if(.not. associated(p)) return
00085          ! get old size
00086          nold = min(size(p), n)
00087          !  ... keep old values
00088          if (nold > 0 .and. n > 0) psmile_reallocate_dble(1:nold) = p(1:nold)
00089 
00090          deallocate(p, stat = ierror)
00091 
00092          if (ierror > 0) then
00093             ierrp (1) = ierror
00094             ierror = PRISM_Error_Dealloc
00095 
00096             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00097                   ierrp, 1, __FILE__, __LINE__ )
00098             return
00099          endif
00100       end function psmile_reallocate_dble
00101 
00102       function psmile_reallocate_real(p, n)
00103          real, pointer, dimension(:) :: p, psmile_reallocate_real
00104          integer, intent(in) :: n
00105          integer :: nold
00106          integer, parameter :: nerrp = 2
00107          integer :: ierror, ierrp (nerrp)
00108 
00109          allocate(psmile_reallocate_real(1:n), stat=ierror)
00110 
00111          if (ierror > 0) then
00112             ierrp (1) = ierror
00113             ierrp (2) = n
00114             ierror = PRISM_Error_Alloc
00115 
00116             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00117                   ierrp, 2, __FILE__, __LINE__ )
00118             return
00119          endif
00120 
00121          if(.not. associated(p)) return
00122          ! get old size
00123          nold = min(size(p), n)
00124          !  ... keep old values
00125          if (nold > 0 .and. n > 0) psmile_reallocate_real(1:nold) = p(1:nold)
00126 
00127          deallocate(p, stat = ierror)
00128 
00129          if (ierror > 0) then
00130             ierrp (1) = ierror
00131             ierror = PRISM_Error_Dealloc
00132 
00133             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00134                   ierrp, 1, __FILE__, __LINE__ )
00135             return
00136          endif
00137       end function psmile_reallocate_real
00138 
00139       function psmile_reallocate_int(p, n)
00140          integer, pointer, dimension(:) :: p, psmile_reallocate_int
00141          integer, intent(in) :: n
00142          integer :: nold
00143          integer, parameter :: nerrp = 2
00144          integer :: ierror, ierrp (nerrp)
00145 
00146          allocate(psmile_reallocate_int(1:n), stat=ierror)
00147 
00148          if (ierror > 0) then
00149             ierrp (1) = ierror
00150             ierrp (2) = n
00151             ierror = PRISM_Error_Alloc
00152 
00153             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00154                   ierrp, 2, __FILE__, __LINE__ )
00155             return
00156          endif
00157 
00158          if(.not. associated(p)) return
00159          ! get old size
00160          nold = min(size(p), n)
00161          !  ... keep old values
00162          if (nold > 0 .and. n > 0) psmile_reallocate_int(1:nold) = p(1:nold)
00163 
00164          deallocate(p, stat = ierror)
00165 
00166          if (ierror > 0) then
00167             ierrp (1) = ierror
00168             ierror = PRISM_Error_Dealloc
00169 
00170             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00171                   ierrp, 1, __FILE__, __LINE__ )
00172             return
00173          endif
00174       end function psmile_reallocate_int
00175 
00176       function psmile_reallocate_log(p, n)
00177          logical, pointer, dimension(:) :: p, psmile_reallocate_log
00178          integer, intent(in) :: n
00179          integer :: nold
00180          integer, parameter :: nerrp = 2
00181          integer :: ierror, ierrp (nerrp)
00182 
00183          allocate(psmile_reallocate_log(1:n), stat=ierror)
00184 
00185          if (ierror > 0) then
00186             ierrp (1) = ierror
00187             ierrp (2) = n
00188             ierror = PRISM_Error_Alloc
00189 
00190             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00191                   ierrp, 2, __FILE__, __LINE__ )
00192             return
00193          endif
00194 
00195          if(.not. associated(p)) return
00196          ! get old size
00197          nold = min(size(p), n)
00198          !  ... keep old values
00199          if (nold > 0 .and. n > 0) psmile_reallocate_log(1:nold) = p(1:nold)
00200 
00201          deallocate(p, stat = ierror)
00202 
00203          if (ierror > 0) then
00204             ierrp (1) = ierror
00205             ierror = PRISM_Error_Dealloc
00206 
00207             call psmile_error ( ierror, 'psmile_reallocate_dble', &
00208                   ierrp, 1, __FILE__, __LINE__ )
00209             return
00210          endif
00211       end function psmile_reallocate_log
00212 
00213       function psmile_reallocate_sai(p, n)
00214          type (send_appl_information), pointer, dimension(:) :: p, psmile_reallocate_sai
00215          integer, intent(in) :: n
00216          integer :: nold
00217          integer, parameter :: nerrp = 2
00218          integer :: ierror, ierrp (nerrp)
00219 
00220          allocate(psmile_reallocate_sai(1:n), stat=ierror)
00221 
00222          if (ierror > 0) then
00223             ierrp (1) = ierror
00224             ierrp (2) = n
00225             ierror = PRISM_Error_Alloc
00226 
00227             call psmile_error ( ierror, 'psmile_reallocate_sai', &
00228                   ierrp, 2, __FILE__, __LINE__ )
00229             return
00230          endif
00231 
00232          if(.not. associated(p)) return
00233          ! get old size
00234          nold = min(size(p), n)
00235          !  ... keep old values
00236          if (nold > 0 .and. n > 0) psmile_reallocate_sai(1:nold) = p(1:nold)
00237 
00238          deallocate(p, stat = ierror)
00239 
00240          if (ierror > 0) then
00241             ierrp (1) = ierror
00242             ierror = PRISM_Error_Dealloc
00243 
00244             call psmile_error ( ierror, 'psmile_reallocate_sai', &
00245                   ierrp, 1, __FILE__, __LINE__ )
00246             return
00247          endif
00248       end function psmile_reallocate_sai
00249 
00250       function psmile_reallocate_si(p, n)
00251          type (send_information), pointer, dimension(:) :: p, psmile_reallocate_si
00252          integer, intent(in) :: n
00253          integer :: nold
00254          integer, parameter :: nerrp = 2
00255          integer :: ierror, ierrp (nerrp)
00256 
00257          allocate(psmile_reallocate_si(1:n), stat=ierror)
00258 
00259          if (ierror > 0) then
00260             ierrp (1) = ierror
00261             ierrp (2) = n
00262             ierror = PRISM_Error_Alloc
00263 
00264             call psmile_error ( ierror, 'psmile_reallocate_si', &
00265                   ierrp, 2, __FILE__, __LINE__ )
00266             return
00267          endif
00268 
00269          if(.not. associated(p)) return
00270          ! get old size
00271          nold = min(size(p), n)
00272          !  ... keep old values
00273          if (nold > 0 .and. n > 0) psmile_reallocate_si(1:nold) = p(1:nold)
00274 
00275          deallocate(p, stat = ierror)
00276 
00277          if (ierror > 0) then
00278             ierrp (1) = ierror
00279             ierror = PRISM_Error_Dealloc
00280 
00281             call psmile_error ( ierror, 'psmile_reallocate_si', &
00282                   ierrp, 1, __FILE__, __LINE__ )
00283             return
00284          endif
00285       end function psmile_reallocate_si
00286 
00287       function psmile_reallocate_ri(p, n)
00288          type (recv_information), pointer, dimension(:) :: p, psmile_reallocate_ri
00289          integer, intent(in) :: n
00290          integer :: nold
00291          integer, parameter :: nerrp = 2
00292          integer :: ierror, ierrp (nerrp)
00293 
00294          allocate(psmile_reallocate_ri(1:n), stat=ierror)
00295 
00296          if (ierror > 0) then
00297             ierrp (1) = ierror
00298             ierrp (2) = n
00299             ierror = PRISM_Error_Alloc
00300 
00301             call psmile_error ( ierror, 'psmile_reallocate_ri', &
00302                   ierrp, 2, __FILE__, __LINE__ )
00303             return
00304          endif
00305 
00306          if(.not. associated(p)) return
00307          ! get old size
00308          nold = min(size(p), n)
00309          !  ... keep old values
00310          if (nold > 0 .and. n > 0) psmile_reallocate_ri(1:nold) = p(1:nold)
00311 
00312          deallocate(p, stat = ierror)
00313 
00314          if (ierror > 0) then
00315             ierrp (1) = ierror
00316             ierror = PRISM_Error_Dealloc
00317 
00318             call psmile_error ( ierror, 'psmile_reallocate_ri', &
00319                   ierrp, 1, __FILE__, __LINE__ )
00320             return
00321          endif
00322       end function psmile_reallocate_ri
00323 
00324       function psmile_reallocate_sfi(p, n)
00325          type (send_field_information), pointer, dimension(:) :: p, psmile_reallocate_sfi
00326          integer, intent(in) :: n
00327          integer :: nold
00328          integer, parameter :: nerrp = 2
00329          integer :: ierror, ierrp (nerrp)
00330 
00331          allocate(psmile_reallocate_sfi(1:n), stat=ierror)
00332 
00333          if (ierror > 0) then
00334             ierrp (1) = ierror
00335             ierrp (2) = n
00336             ierror = PRISM_Error_Alloc
00337 
00338             call psmile_error ( ierror, 'psmile_reallocate_sfi', &
00339                   ierrp, 2, __FILE__, __LINE__ )
00340             return
00341          endif
00342 
00343          if(.not. associated(p)) return
00344          ! get old size
00345          nold = min(size(p), n)
00346          !  ... keep old values
00347          if (nold > 0 .and. n > 0) psmile_reallocate_sfi(1:nold) = p(1:nold)
00348 
00349          deallocate(p, stat = ierror)
00350 
00351          if (ierror > 0) then
00352             ierrp (1) = ierror
00353             ierror = PRISM_Error_Dealloc
00354 
00355             call psmile_error ( ierror, 'psmile_reallocate_sfi', &
00356                   ierrp, 1, __FILE__, __LINE__ )
00357             return
00358          endif
00359       end function psmile_reallocate_sfi
00360 
00361       function psmile_reallocate_rfi(p, n)
00362          type (recv_field_information), pointer, dimension(:) :: p, psmile_reallocate_rfi
00363          integer, intent(in) :: n
00364          integer :: nold
00365          integer, parameter :: nerrp = 2
00366          integer :: ierror, ierrp (nerrp)
00367 
00368          allocate(psmile_reallocate_rfi(1:n), stat=ierror)
00369 
00370          if (ierror > 0) then
00371             ierrp (1) = ierror
00372             ierrp (2) = n
00373             ierror = PRISM_Error_Alloc
00374 
00375             call psmile_error ( ierror, 'psmile_reallocate_rfi', &
00376                   ierrp, 2, __FILE__, __LINE__ )
00377             return
00378          endif
00379 
00380          if(.not. associated(p)) return
00381          ! get old size
00382          nold = min(size(p), n)
00383          !  ... keep old values
00384          if (nold > 0 .and. n > 0) psmile_reallocate_rfi(1:nold) = p(1:nold)
00385 
00386          deallocate(p, stat = ierror)
00387 
00388          if (ierror > 0) then
00389             ierrp (1) = ierror
00390             ierror = PRISM_Error_Dealloc
00391 
00392             call psmile_error ( ierror, 'psmile_reallocate_rfi', &
00393                   ierrp, 1, __FILE__, __LINE__ )
00394             return
00395          endif
00396       end function psmile_reallocate_rfi
00397 
00398       function psmile_reallocate_ugd(p, n)
00399          type (user_grid_data), pointer, dimension(:) :: p, psmile_reallocate_ugd
00400          integer, intent(in) :: n
00401          integer :: nold
00402          integer, parameter :: nerrp = 2
00403          integer :: ierror, ierrp (nerrp)
00404 
00405          allocate(psmile_reallocate_ugd(1:n), stat=ierror)
00406 
00407          if (ierror > 0) then
00408             ierrp (1) = ierror
00409             ierrp (2) = n
00410             ierror = PRISM_Error_Alloc
00411 
00412             call psmile_error ( ierror, 'psmile_reallocate_ugd', &
00413                   ierrp, 2, __FILE__, __LINE__ )
00414             return
00415          endif
00416 
00417          if(.not. associated(p)) return
00418          ! get old size
00419          nold = min(size(p), n)
00420          !  ... keep old values
00421          if (nold > 0 .and. n > 0) psmile_reallocate_ugd(1:nold) = p(1:nold)
00422 
00423          deallocate(p, stat = ierror)
00424 
00425          if (ierror > 0) then
00426             ierrp (1) = ierror
00427             ierror = PRISM_Error_Dealloc
00428 
00429             call psmile_error ( ierror, 'psmile_reallocate_ugd', &
00430                   ierrp, 1, __FILE__, __LINE__ )
00431             return
00432          endif
00433       end function psmile_reallocate_ugd
00434 
00435       function psmile_reallocate_upd(p, n)
00436          type (user_point_data), pointer, dimension(:) :: p, psmile_reallocate_upd
00437          integer, intent(in) :: n
00438          integer :: nold
00439          integer, parameter :: nerrp = 2
00440          integer :: ierror, ierrp (nerrp)
00441 
00442          allocate(psmile_reallocate_upd(1:n), stat=ierror)
00443 
00444          if (ierror > 0) then
00445             ierrp (1) = ierror
00446             ierrp (2) = n
00447             ierror = PRISM_Error_Alloc
00448 
00449             call psmile_error ( ierror, 'psmile_reallocate_upd', &
00450                   ierrp, 2, __FILE__, __LINE__ )
00451             return
00452          endif
00453 
00454          if(.not. associated(p)) return
00455          ! get old size
00456          nold = min(size(p), n)
00457          !  ... keep old values
00458          if (nold > 0 .and. n > 0) psmile_reallocate_upd(1:nold) = p(1:nold)
00459 
00460          deallocate(p, stat = ierror)
00461 
00462          if (ierror > 0) then
00463             ierrp (1) = ierror
00464             ierror = PRISM_Error_Dealloc
00465 
00466             call psmile_error ( ierror, 'psmile_reallocate_upd', &
00467                   ierrp, 1, __FILE__, __LINE__ )
00468             return
00469          endif
00470       end function psmile_reallocate_upd
00471 
00472       function psmile_reallocate_umd(p, n)
00473          type (user_mask_data), pointer, dimension(:) :: p, psmile_reallocate_umd
00474          integer, intent(in) :: n
00475          integer :: nold
00476          integer, parameter :: nerrp = 2
00477          integer :: ierror, ierrp (nerrp)
00478 
00479          allocate(psmile_reallocate_umd(1:n), stat=ierror)
00480 
00481          if (ierror > 0) then
00482             ierrp (1) = ierror
00483             ierrp (2) = n
00484             ierror = PRISM_Error_Alloc
00485 
00486             call psmile_error ( ierror, 'psmile_reallocate_umd', &
00487                   ierrp, 2, __FILE__, __LINE__ )
00488             return
00489          endif
00490 
00491          if(.not. associated(p)) return
00492          ! get old size
00493          nold = min(size(p), n)
00494          !  ... keep old values
00495          if (nold > 0 .and. n > 0) psmile_reallocate_umd(1:nold) = p(1:nold)
00496 
00497          deallocate(p, stat = ierror)
00498 
00499          if (ierror > 0) then
00500             ierrp (1) = ierror
00501             ierror = PRISM_Error_Dealloc
00502 
00503             call psmile_error ( ierror, 'psmile_reallocate_umd', &
00504                   ierrp, 1, __FILE__, __LINE__ )
00505             return
00506          endif
00507       end function psmile_reallocate_umd
00508 
00509       function psmile_reallocate_uvd(p, n)
00510          type (user_var_data), pointer, dimension(:) :: p, psmile_reallocate_uvd
00511          integer, intent(in) :: n
00512          integer :: nold
00513          integer, parameter :: nerrp = 2
00514          integer :: ierror, ierrp (nerrp)
00515 
00516          allocate(psmile_reallocate_uvd(1:n), stat=ierror)
00517 
00518          if (ierror > 0) then
00519             ierrp (1) = ierror
00520             ierrp (2) = n
00521             ierror = PRISM_Error_Alloc
00522 
00523             call psmile_error ( ierror, 'psmile_reallocate_uvd', &
00524                   ierrp, 2, __FILE__, __LINE__ )
00525             return
00526          endif
00527 
00528          if(.not. associated(p)) return
00529          ! get old size
00530          nold = min(size(p), n)
00531          !  ... keep old values
00532          if (nold > 0 .and. n > 0) psmile_reallocate_uvd(1:nold) = p(1:nold)
00533 
00534          deallocate(p, stat = ierror)
00535 
00536          if (ierror > 0) then
00537             ierrp (1) = ierror
00538             ierror = PRISM_Error_Dealloc
00539 
00540             call psmile_error ( ierror, 'psmile_reallocate_uvd', &
00541                   ierrp, 1, __FILE__, __LINE__ )
00542             return
00543          endif
00544       end function psmile_reallocate_uvd
00545 
00546       function psmile_reallocate_cp(p, n)
00547          type (ch_ptr), pointer, dimension(:) :: p, psmile_reallocate_cp
00548          integer, intent(in) :: n
00549          integer :: nold
00550          integer, parameter :: nerrp = 2
00551          integer :: ierror, ierrp (nerrp)
00552 
00553          allocate(psmile_reallocate_cp(1:n), stat=ierror)
00554 
00555          if (ierror > 0) then
00556             ierrp (1) = ierror
00557             ierrp (2) = n
00558             ierror = PRISM_Error_Alloc
00559 
00560             call psmile_error ( ierror, 'psmile_reallocate_cp', &
00561                   ierrp, 2, __FILE__, __LINE__ )
00562             return
00563          endif
00564 
00565          if(.not. associated(p)) return
00566          ! get old size
00567          nold = min(size(p), n)
00568          !  ... keep old values
00569          if (nold > 0 .and. n > 0) psmile_reallocate_cp(1:nold) = p(1:nold)
00570 
00571          deallocate(p, stat = ierror)
00572 
00573          if (ierror > 0) then
00574             ierrp (1) = ierror
00575             ierror = PRISM_Error_Dealloc
00576 
00577             call psmile_error ( ierror, 'psmile_reallocate_cp', &
00578                   ierrp, 1, __FILE__, __LINE__ )
00579             return
00580          endif
00581       end function psmile_reallocate_cp
00582 
00583       function psmile_reallocate_ts(p, n)
00584          type (psmile_time_struct), pointer, dimension(:) :: p, psmile_reallocate_ts
00585          integer, intent(in) :: n
00586          integer :: nold
00587          integer, parameter :: nerrp = 2
00588          integer :: ierror, ierrp (nerrp)
00589 
00590          allocate(psmile_reallocate_ts(1:n), stat=ierror)
00591 
00592          if (ierror > 0) then
00593             ierrp (1) = ierror
00594             ierrp (2) = n
00595             ierror = PRISM_Error_Alloc
00596 
00597             call psmile_error ( ierror, 'psmile_reallocate_ts', &
00598                   ierrp, 2, __FILE__, __LINE__ )
00599             return
00600          endif
00601 
00602          if(.not. associated(p)) return
00603          ! get old size
00604          nold = min(size(p), n)
00605          !  ... keep old values
00606          if (nold > 0 .and. n > 0) psmile_reallocate_ts(1:nold) = p(1:nold)
00607 
00608          deallocate(p, stat = ierror)
00609 
00610          if (ierror > 0) then
00611             ierrp (1) = ierror
00612             ierror = PRISM_Error_Dealloc
00613 
00614             call psmile_error ( ierror, 'psmile_reallocate_ts', &
00615                   ierrp, 1, __FILE__, __LINE__ )
00616             return
00617          endif
00618       end function psmile_reallocate_ts
00619 
00620 end module psmile_reallocate