hwrf-baseline-20120103-1354/ungrib/src/new_storage.F

   1 module storage_module
   2   use gridinfo
   3   implicit none
   4   private
   5   public :: get_storage
   6   public :: get_dims
   7   public :: get_plvls
   8   public :: put_storage
   9   public :: llstor_start
  10   public :: clear_storage
  11   public :: refr_storage
  12   public :: refw_storage
  13   public :: is_there
  14   public :: print_storage
  15   public :: setll
  16   public :: getll
  17
  18   integer, parameter :: idlen = 8
  19   integer :: verbose = 0  ! 0 = no prints; 1 = some prints; 2 = more; etc.
  20
  21   type node2
  22      character(len=idlen) :: id
  23      real, pointer, dimension(:,:) :: data2d
  24      type(mapinfo) :: data_map
  25      type(node2), pointer :: next
  26   end type node2
  27
  28   type node1
  29      integer :: id
  30      type(node1), pointer :: next
  31      type(node2), pointer :: first
  32   end type node1
  33
  34   type(node1), target :: root
  35   type(node1), pointer :: nnode
  36   type(node2), pointer :: current
  37   type(node2), pointer :: hold
  38   type(node1), pointer :: holdnn
  39
  40   integer, public :: iferr
  41
  42 contains
  43
  44   subroutine llstor_start(icode)
  45     implicit none
  46     integer, intent(in) :: icode
  47 !
  48 ! First, check to see that the list ICODE has not already been started:
  49 !
  50     nnode => root
  51     SEARCH : do while (associated(nnode%next))
  52        nnode => nnode%next
  53        if (nnode%id == icode) then
  54           if (verbose.gt.0) write(*,&
  55                '(/,"LLSTOR_START: NNODE EXISTS, not starting ", I8, /)') icode
  56           return
  57        endif
  58     enddo SEARCH
  59 !
  60 ! Since it is a new ICODE, add it to the list of lists:
  61 !
  62     allocate(nnode%next)
  63     nnode => nnode%next
  64     nnode%id = icode
  65     if (verbose.gt.0) write(*, '(/,"NNODE%ID = ", I8, /)') nnode%id
  66     allocate(nnode%first)
  67     nnode%first%id = 'Root'
  68     nullify(nnode%first%next)
  69     nullify (nnode%next)
  70   end subroutine llstor_start
  71
  72   subroutine clear_storage
  73     implicit none
  74
  75     if (verbose > 0) then
  76        print*, 'Call clear_storage.'
  77     endif
  78
  79     SEARCH : do
  80
  81        nnode => root
  82        SCANF : do while (associated(nnode%next))
  83           holdnn => nnode
  84           nnode => nnode%next
  85        enddo SCANF
  86        if (nnode%id == 0) exit SEARCH
  87
  88        N2: do
  89           current => nnode%first
  90           do while (associated(current%next))
  91              hold => current
  92              current => current%next
  93           enddo
  94           if (current%id /= "Root") then
  95              if (associated(current%data2d)) then
  96                 if (verbose > 0) then
  97                    print*, 'Deallocating and nullifying 2d.', &
  98                         nnode%id, current%id
  99                 endif
 100                 deallocate(current%data2d)
 101                 nullify(current%data2d)
 102              endif
 103           endif
 104           nullify(hold%next)
 105           if (current%id == nnode%first%id) then
 106              deallocate(current)
 107              nullify(current)
 108              exit N2
 109           endif
 110        enddo N2
 111        nullify(holdnn%next)
 112
 113     enddo SEARCH
 114
 115   end subroutine clear_storage
 116
 117   subroutine find_node1(inname)
 118     implicit none
 119     integer :: inname, name
 120     name = inname
 121     nnode => root
 122     SEARCH : do while (associated(nnode%next))
 123        nnode => nnode%next
 124        if (nnode%id == name) then
 125           iferr = 0
 126           return
 127        endif
 128     enddo SEARCH
 129     if (verbose > 0) then
 130        print '("FIND_NODE1: Name not found:  ", I8)',  name
 131     endif
 132     iferr = 1
 133   end subroutine find_node1
 134
 135
 136   subroutine get_plvls(plvl, maxlvl, nlvl)
 137     implicit none
 138     integer :: maxlvl, nlvl
 139     real, dimension(maxlvl) :: plvl
 140     integer :: nn
 141
 142     nnode => root
 143     nlvl = 0
 144     plvl = -99999
 145     SEARCH : do while (associated(nnode%next))
 146        nnode => nnode%next
 147        nlvl = nlvl + 1
 148        LEVLOOP : do nn = 1, nlvl
 149           if (nnode%id > plvl(nn)) then
 150              plvl(nn+1:maxlvl) = plvl(nn:maxlvl-1)
 151              plvl(nn) = float(nnode%id)
 152              exit LEVLOOP
 153           endif
 154        enddo LEVLOOP
 155     enddo SEARCH
 156   end subroutine get_plvls
 157
 158   subroutine put_storage(icode, inname, data, idum, jdum)
 159     implicit none
 160     character(len=*) :: inname
 161     character(len=idlen) :: name
 162     integer :: idum, jdum
 163     integer :: icode
 164     real, dimension(:,:) :: data
 165
 166     name = inname
 167
 168     if (verbose>0) print*, 'Put Storage: '
 169
 170     call find_node1(icode)
 171     if (iferr /= 0) then
 172        call llstor_start(icode)
 173     endif
 174     current => nnode%first
 175
 176     SEARCH : do while (associated(current%next))
 177        current => current%next
 178        if (current%id == name) then
 179           current%data2d = data
 180           current%data_map = map
 181           if (verbose.gt.0) write(*,'("PUT_STORAGE: Overwriting ", A,&
 182             &" to ID ", I8, "   Value: ", F16.6)') current%id, nnode%id,&
 183             data(1,1)
 184           return
 185        endif
 186     enddo SEARCH
 187     allocate(current%next)
 188     current => current%next
 189     current%id = name
 190     allocate(current%data2d(size(data,1),size(data,2)))
 191     current%data2d = data
 192     current%data_map = map
 193     nullify (current%next)
 194     if (verbose.gt.0) write(*,'("PUT_STORAGE: Writing ", A,&
 195          &" to ID ", I8, "   Value: ", F16.6)') current%id, nnode%id, data(1,1)
 196
 197   end subroutine put_storage
 198
 199   subroutine refw_storage(icode, name, Pdata, idum, jdum)
 200     implicit none
 201     character(len=*) :: name
 202     integer :: icode
 203     integer :: idum, jdum
 204     real, pointer, dimension(:,:) :: Pdata
 205
 206     call find_node1(icode)
 207     if (iferr /= 0) then
 208        call llstor_start(icode)
 209     endif
 210     current => nnode%first
 211
 212     SEARCH : do while (associated(current%next))
 213        current => current%next
 214        if (current%id == name) then
 215           if (associated(current%data2d)) then
 216              deallocate(current%data2d)
 217              nullify(current%data2d)
 218           endif
 219           current%data2d => Pdata
 220           current%data_map = map
 221           if (verbose.gt.0) write(*,'("REFW_STORAGE: OverWriting ", A,&
 222                &" to ID ", I8, "   Value: ", F16.6)') current%id, nnode%id,&
 223                current%data2d(1,1)
 224           return
 225        endif
 226     enddo SEARCH
 227     allocate(current%next)
 228     current => current%next
 229     current%id = name
 230     nullify(current%data2d)
 231     current%data2d => Pdata
 232     current%data_map = map
 233     nullify(current%next)
 234
 235     if (verbose.gt.0) write(*,'("REFW_STORAGE: Writing ", A,&
 236          &" to ID ", I8, "   Value: ", F16.6)') current%id, nnode%id,&
 237          current%data2d(1,1)
 238
 239   end subroutine refw_storage
 240
 241   subroutine get_storage(icode, name, data, idum, jdum)
 242     implicit none
 243     character(len=*) :: name
 244     integer :: icode
 245     integer :: idum, jdum
 246     real, dimension(:,:) :: data
 247
 248     call find_node1(icode)
 249     if (iferr /= 0) then
 250        print*, 'Cannot find code ', icode, ' in routine GET_STORAGE.'
 251        stop 'GET_STORAGE_code'
 252     endif
 253     current => nnode%first
 254
 255     SEARCH : do while (associated(current%next))
 256        current => current%next
 257        if (current%id == name) then
 258           data = current%data2d
 259           map = current%data_map
 260           if (verbose.gt.0) write(*,'("GET_STORAGE: READING ", A,&
 261               &" at ID ", I8, "   Value: ", F16.6)') current%id, nnode%id,&
 262               & data(1,1)
 263           return
 264        endif
 265     enddo SEARCH
 266     write(*,'("GET_STORAGE : NAME not found: ", A)') name
 267
 268   end subroutine get_storage
 269
 270   subroutine refr_storage(icode, name, Pdata, idum, jdum)
 271     implicit none
 272     character(len=*) :: name
 273     integer :: icode
 274     integer :: idum, jdum
 275     real, pointer, dimension(:,:) :: Pdata
 276
 277     call find_node1(icode)
 278     if (iferr /= 0) then
 279        print*, 'Cannot find code ', icode, ' in routine REFR_STORAGE.'
 280        STOP 'REFR_STORAGE_code'
 281     endif
 282     current => nnode%first
 283
 284     SEARCH : do while (associated(current%next))
 285        current => current%next
 286        if (current%id == name) then
 287           Pdata => current%data2d
 288           map = current%data_map
 289           if (verbose.gt.0) write(*,'("REFR_STORAGE: Referencing ", A,&
 290          &" at ID ", I8, "   Value: ", F16.6)') current%id, nnode%id,&
 291          Pdata(1,1)
 292           return
 293        endif
 294     enddo SEARCH
 295     print '("REFR_STORAGE : NAME not found: ", A)', name
 296
 297   end subroutine refr_storage
 298
 299   subroutine llstor_remove(icode, name)
 300     implicit none
 301     character(len=*) :: name
 302     integer :: icode
 303
 304     call find_node1(icode)
 305     if (iferr /= 0) then
 306        STOP 'find_node1'
 307     endif
 308     current => nnode%first
 309
 310     do while (current%id /= name )
 311        if (.not. associated(current%next)) then
 312           print*, 'Not there : ', name
 313           return
 314        endif
 315        hold => current
 316        current => current%next
 317     enddo
 318
 319     if (associated(current%data2d)) then
 320        deallocate(current%data2d)
 321     endif
 322     nullify(hold%next)
 323     hold%next => current%next
 324     nullify(current%next)
 325     nullify(current)
 326
 327   end subroutine llstor_remove
 328
 329   subroutine get_dims(icode, name)
 330     implicit none
 331     character(len=*) :: name
 332     integer :: icode
 333
 334     call find_node1(icode)
 335     if (iferr /= 0) then
 336        STOP 'get_dims'
 337     end if
 338     current => nnode%first
 339
 340     SEARCH : do while (associated(current%next))
 341        current => current%next
 342        if (current%id == name) then
 343           map = current%data_map
 344           return
 345        endif
 346     enddo SEARCH
 347
 348   end subroutine get_dims
 349
 350   subroutine print_storage(icode)
 351     implicit none
 352     integer :: isz
 353     integer, optional :: icode
 354
 355     if (present(icode)) then
 356        call find_node1(icode)
 357        if (iferr /= 0) then
 358           STOP 'print_storage'
 359        end if
 360        print '("PRINT_NODE1: id = ", I8)' , nnode%id
 361        current => nnode%first
 362
 363        print*
 364        if (.not. associated(current)) then
 365           print '("Nothing there.")'
 366           return
 367        endif
 368        do while ( associated(current%next))
 369           if (current%id == 'Root') then
 370              print*, 'id = ', current%id
 371           elseif (current%id /= 'Root') then
 372
 373              if (associated(current%data2d)) then
 374                 isz = size(current%data2d)
 375                 print*, current%id, ' = ', current%data2d(1,1)
 376              endif
 377
 378           endif
 379           current => current%next
 380        enddo
 381        if (current%id == 'Root') then
 382           print*, 'id = ', current%id
 383        elseif (current%id /= 'Root') then
 384           if (associated(current%data2d)) then
 385              isz = size(current%data2d)
 386              print*, current%id, ' = ', current%data2d(1,1)
 387           endif
 388        endif
 389        current => current%next
 390        print*
 391
 392     else
 393        nnode => root
 394        do while (associated(nnode%next))
 395           nnode => nnode%next
 396           print '("PRINT_NODE1: id = ", I8)' , nnode%id
 397
 398
 399           current => nnode%first
 400
 401           print*
 402           if (.not. associated(current)) then
 403              print '("Nothing there.")'
 404              return
 405           endif
 406           do while ( associated(current%next))
 407              if (current%id == 'Root') then
 408                 print*, 'id = ', current%id
 409              elseif (current%id /= 'Root') then
 410                 if (associated(current%data2d)) then
 411                    isz = size(current%data2d)
 412                    print*, current%id, ' = ', current%data2d(1,1), isz
 413                 endif
 414              endif
 415              current => current%next
 416           enddo
 417           if (current%id == 'Root') then
 418              print*, 'id = ', current%id
 419           elseif (current%id /= 'Root') then
 420              if (associated(current%data2d)) then
 421                 isz = size(current%data2d)
 422                 print*, current%id, ' = ', current%data2d(1,1), isz
 423              endif
 424           endif
 425           current => current%next
 426           print*
 427
 428        enddo
 429     endif
 430   end subroutine print_storage
 431
 432   logical function is_there(icode, name) RESULT(answer)
 433     implicit none
 434     character(len=*) :: name
 435     integer :: icode
 436
 437     answer = .FALSE.
 438
 439     if (verbose > 0) then
 440        write(*,'("Is there ",A," at ", i8, "?")', advance="NO") name, icode
 441     endif
 442
 443     call find_node1(icode)
 444     if (iferr /= 0) go to 1000
 445
 446     current => nnode%first
 447
 448     SEARCH : do while (associated(current%next))
 449        current => current%next
 450        if (current%id == name) then
 451           answer = .TRUE.
 452           exit SEARCH
 453        endif
 454     enddo SEARCH
 455
 456 1000 continue
 457
 458     if (verbose > 0) then
 459        write(*,*) answer
 460     endif
 461
 462
 463   end function is_there
 464
 465   subroutine setll(ivrb)
 466     implicit none
 467     integer, optional :: ivrb
 468     if (present(ivrb)) verbose = ivrb
 469   end subroutine setll
 470
 471   subroutine getll(ivrb)
 472     implicit none
 473     integer, optional :: ivrb
 474     if (present(ivrb)) ivrb = verbose
 475   end subroutine getll
 476
 477 end module storage_module
 478