ungrib/src/new_storage.F

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