external/io_grib2/g2lib/realloc.F

   1       module re_alloc
   2
   3       interface realloc
   4          module procedure realloc_c1
   5          module procedure realloc_r
   6          module procedure realloc_i
   7 !!         subroutine realloc_c1(c,n,m,istat)
   8 !!            character(len=1),pointer,dimension(:) :: c
   9 !!            integer :: n,m
  10 !!            integer :: istat
  11 !!         end subroutine
  12 !!         subroutine realloc_r(c,n,m,istat)
  13 !!            real,pointer,dimension(:) :: c
  14 !!            integer :: n,m
  15 !!            integer :: istat
  16 !!         end subroutine
  17 !!         subroutine realloc_i(c,n,m,istat)
  18 !!            integer,pointer,dimension(:) :: c
  19 !!            integer :: n,m
  20 !!            integer :: istat
  21 !!         end subroutine
  22       end interface
  23
  24       contains
  25
  26          subroutine realloc_c1(c,n,m,istat)
  27             character(len=1),pointer,dimension(:) :: c
  28             integer,intent(in) :: n,m
  29             integer,intent(out) :: istat
  30             integer :: num
  31             character(len=1),pointer,dimension(:) :: tmp
  32
  33             istat=0
  34             if ( (n<0) .OR. (m<=0) ) then
  35                istat=10
  36                return
  37             endif
  38
  39             if ( .not. associated(c) ) then
  40                allocate(c(m),stat=istat)   ! allocate new memory
  41                return
  42             endif
  43
  44             tmp=>c                      ! save pointer to original mem
  45             nullify(c)
  46             allocate(c(m),stat=istat)   ! allocate new memory
  47             if ( istat /= 0 ) then
  48                c=>tmp
  49                return
  50             endif
  51             if ( n /= 0 ) then
  52                num=min(n,m)
  53                c(1:num)=tmp(1:num)      ! copy data from orig mem to new loc.
  54             endif
  55             deallocate(tmp)             ! deallocate original memory
  56             return
  57          end subroutine
  58
  59          subroutine realloc_r(c,n,m,istat)
  60             real,pointer,dimension(:) :: c
  61             integer,intent(in) :: n,m
  62             integer,intent(out) :: istat
  63             integer :: num
  64             real,pointer,dimension(:) :: tmp
  65
  66             istat=0
  67             if ( (n<0) .OR. (m<=0) ) then
  68                istat=10
  69                return
  70             endif
  71
  72             if ( .not. associated(c) ) then
  73                allocate(c(m),stat=istat)   ! allocate new memory
  74                return
  75             endif
  76
  77             tmp=>c                      ! save pointer to original mem
  78             nullify(c)
  79             allocate(c(m),stat=istat)   ! allocate new memory
  80             if ( istat /= 0 ) then
  81                c=>tmp
  82                return
  83             endif
  84             if ( n /= 0 ) then
  85                num=min(n,m)
  86                c(1:num)=tmp(1:num)      ! copy data from orig mem to new loc.
  87             endif
  88             deallocate(tmp)             ! deallocate original memory
  89             return
  90          end subroutine
  91
  92          subroutine realloc_i(c,n,m,istat)
  93             integer,pointer,dimension(:) :: c
  94             integer,intent(in) :: n,m
  95             integer,intent(out) :: istat
  96             integer :: num
  97             integer,pointer,dimension(:) :: tmp
  98
  99             istat=0
 100             if ( (n<0) .OR. (m<=0) ) then
 101                istat=10
 102                return
 103             endif
 104
 105             if ( .not. associated(c) ) then
 106                allocate(c(m),stat=istat)   ! allocate new memory
 107                return
 108             endif
 109
 110             tmp=>c                      ! save pointer to original mem
 111             nullify(c)
 112             allocate(c(m),stat=istat)   ! allocate new memory
 113             if ( istat /= 0 ) then
 114                c=>tmp
 115                return
 116             endif
 117             if ( n /= 0 ) then
 118                num=min(n,m)
 119                c(1:num)=tmp(1:num)      ! copy data from orig mem to new loc.
 120             endif
 121             deallocate(tmp)             ! deallocate original memory
 122             return
 123          end subroutine
 124
 125       end module re_alloc