! Dusan Jovic, NCEP, 2008 program diodump use dio implicit none type(dio_file) :: rfile integer :: iret integer :: n character(len=32) :: name integer :: rank, dtype integer,dimension(10) :: bounds integer, dimension(512) :: header character(len=1024*1024) :: v1c real(kind=real4_kind) :: vr4_0 real(kind=real4_kind), dimension(:), allocatable :: vr4_1 real(kind=real4_kind), dimension(:,:), allocatable :: vr4_2 real(kind=real4_kind), dimension(:,:,:), allocatable :: vr4_3 real(kind=real4_kind), dimension(:,:,:,:), allocatable :: vr4_4 real(kind=real8_kind) :: vr8_0 real(kind=real8_kind), dimension(:), allocatable :: vr8_1 real(kind=real8_kind), dimension(:,:), allocatable :: vr8_2 real(kind=real8_kind), dimension(:,:,:), allocatable :: vr8_3 real(kind=real8_kind), dimension(:,:,:,:), allocatable :: vr8_4 integer(kind=integer4_kind) :: vi4_0 integer(kind=integer4_kind), dimension(:), allocatable :: vi4_1 integer(kind=integer4_kind), dimension(:,:), allocatable :: vi4_2 integer(kind=integer4_kind), dimension(:,:,:), allocatable :: vi4_3 integer(kind=integer4_kind), dimension(:,:,:,:), allocatable :: vi4_4 logical :: v0l logical, dimension(:), allocatable :: v1l logical, dimension(:,:), allocatable :: v2l logical, dimension(:,:,:), allocatable :: v3l character(len=256) :: fname character(len=256) :: carg character(len=256) :: dump_variable integer :: i,j,k, slen integer :: narg, iarg, larg, lstopt integer :: iargc, l narg=iargc() iarg=1 lstopt=0 ! ! parse command line options ! do while (iarg <= narg .and. lstopt == 0) call getarg(iarg,carg) larg=len_trim(carg) print *, iarg , trim(carg) iarg=iarg+1 if (carg(1:1) /= '-') then lstopt=1 iarg=iarg-1 else if (larg == 1) then write(0,*) " diodump: invalid option -" stop 1 else l=2 do while(l <= larg) if(carg(l:l) == '-') then lstopt=1 else if(carg(l:l)=='V' .or. carg(l:l)=='v' ) then IF(L.EQ.LARG) THEN L=0 CALL GETARG(IARG,CARG) LARG=LEN_TRIM(CARG) IARG=IARG+1 ENDIF dump_variable=CARG(L+1:LARG) L=LARG print *, ' dump_variable= ', dump_variable else write(0,*) " diodump: invalid option ",carg(l:l) stop 1 end if l=l+1 end do end if end do ! ! parse command line positional arguments; for now just a filename ! call getarg(iarg,fname) call dio_init(iret=iret) call dio_open(rfile,fname,"READ",iret=iret) do n=1,dio_numrec(rfile) call dio_recinfo(rfile,n,name,rank,dtype,bounds,iret=iret) write(0,*)n,name,rank,dtype if (dtype == DIO_INTEGER4) then if (rank == 0) then call dio_read(rfile,name,vi4_0,header=header,iret=iret) write(*,101)n,name,rank,dtype,vi4_0 call dump_header(header) else if (rank == 1) then allocate(vi4_1(bounds(1):bounds(2))) call dio_read(rfile,name,vi4_1,header=header,iret=iret) write(*,101)n,name,rank,dtype,minval(vi4_1),maxval(vi4_1) call dump_header(header) deallocate(vi4_1) else if (rank == 2) then allocate(vi4_2(bounds(1):bounds(2),bounds(3):bounds(4))) call dio_read(rfile,name,vi4_2,header=header,iret=iret) write(*,101)n,name,rank,dtype,minval(vi4_2),maxval(vi4_2) call dump_header(header) deallocate(vi4_2) else if (rank == 3) then allocate(vi4_3(bounds(1):bounds(2),bounds(3):bounds(4),bounds(5):bounds(6))) call dio_read(rfile,name,vi4_3,header=header,iret=iret) write(*,101)n,name,rank,dtype,minval(vi4_3),maxval(vi4_3) call dump_header(header) deallocate(vi4_3) else if (rank == 4) then allocate(vi4_4(bounds(1):bounds(2),bounds(3):bounds(4),bounds(5):bounds(6),bounds(7):bounds(8))) call dio_read(rfile,name,vi4_4,header=header,iret=iret) write(*,101)n,name,rank,dtype,minval(vi4_4),maxval(vi4_4) call dump_header(header) deallocate(vi4_4) else write(0,*)'unknown rank ',rank end if 101 format(I3,1X,A,I3,I4,2I10) else if (dtype == DIO_REAL4) then if (rank == 0) then call dio_read(rfile,name,vr4_0,header=header,iret=iret) write(*,102)n,name,rank,dtype,vr4_0 call dump_header(header) else if (rank == 1) then allocate(vr4_1(bounds(1):bounds(2))) call dio_read(rfile,name,vr4_1,header=header,iret=iret) write(*,102)n,name,rank,dtype,minval(vr4_1),maxval(vr4_1) call dump_header(header) deallocate(vr4_1) else if (rank == 2) then allocate(vr4_2(bounds(1):bounds(2),bounds(3):bounds(4))) call dio_read(rfile,name,vr4_2,header=header,iret=iret) write(*,102)n,name,rank,dtype,minval(vr4_2),maxval(vr4_2) call dump_header(header) deallocate(vr4_2) else if (rank == 3) then allocate(vr4_3(bounds(1):bounds(2),bounds(3):bounds(4),bounds(5):bounds(6))) call dio_read(rfile,name,vr4_3,header=header,iret=iret) write(*,'(I3,1X,A,I3,I4,3(A,I3,A,I3),A,2E20.10)')n,name,rank,dtype, & "(",bounds(1),":",bounds(2), & ",",bounds(3),":",bounds(4), & ",",bounds(5),":",bounds(6),")", & minval(vr4_3),maxval(vr4_3) call dump_header(header) ! open(40,file=trim(name)) ! do k=bounds(5),bounds(6) ! do j=bounds(3),bounds(4) ! do i=bounds(1),bounds(2) ! write(40,"(Z8.8)") vr4_3(i,j,k) ! end do ! end do ! end do ! close(40) deallocate(vr4_3) else if (rank == 4) then allocate(vr4_4(bounds(1):bounds(2),bounds(3):bounds(4),bounds(5):bounds(6),bounds(7):bounds(8))) call dio_read(rfile,name,vr4_4,header=header,iret=iret) write(*,'(I4,A,I3,I4,4(A,I3,A,I3),A,2E20.10)')n,name,rank,dtype, & "(",bounds(1),":",bounds(2), & ",",bounds(3),":",bounds(4), & ",",bounds(5),":",bounds(6), & ",",bounds(7),":",bounds(8),")", & minval(vr4_4),maxval(vr4_4) call dump_header(header) deallocate(vr4_4) else write(0,*)'unknown rank ',rank end if 102 format (I3,1X,A,I3,I4,2E20.10) else if (dtype == DIO_REAL8) then if (rank == 0) then call dio_read(rfile,name,vr8_0,header=header,iret=iret) write(*,*)n,name,rank,dtype,vr8_0 call dump_header(header) else if (rank == 1) then allocate(vr8_1(bounds(1):bounds(2))) call dio_read(rfile,name,vr8_1,header=header,iret=iret) write(*,*)n,name,rank,dtype,minval(vr8_1),maxval(vr8_1) call dump_header(header) deallocate(vr8_1) else if (rank == 2) then allocate(vr8_2(bounds(1):bounds(2),bounds(3):bounds(4))) call dio_read(rfile,name,vr8_2,header=header,iret=iret) write(*,*)n,name,rank,dtype,minval(vr8_2),maxval(vr8_2) call dump_header(header) deallocate(vr8_2) else if (rank == 3) then allocate(vr8_3(bounds(1):bounds(2),bounds(3):bounds(4),bounds(5):bounds(6))) call dio_read(rfile,name,vr8_3,header=header,iret=iret) write(*,*)n,name,rank, & "(",bounds(1),":",bounds(2), & ",",bounds(3),":",bounds(4), & ",",bounds(5),":",bounds(6),")", & dtype,minval(vr8_3),maxval(vr8_3) call dump_header(header) ! open(40,file=trim(name)) ! do k=bounds(5),bounds(6) ! do j=bounds(3),bounds(4) ! do i=bounds(1),bounds(2) ! write(40,"(Z8.8)") vr8_3(i,j,k) ! end do ! end do ! end do ! close(40) deallocate(vr8_3) else write(0,*)'unknown rank' stop end if ! else if (dtype == DIO_LOGICAL4) then ! if (rank == 0) then ! call dio_read(rfile,name,v0l,header=header,iret=iret) ! write(*,*)n,name,rank,dtype,v0l ! call dump_header(header) ! else if (rank == 1) then ! allocate(v1l(bounds(1):bounds(2))) ! call dio_read(rfile,name,v1l,header=header,iret=iret) ! write(*,*)n,name,rank,dtype!,minval(v1l),maxval(v1l) ! call dump_header(header) ! deallocate(v1l) ! else if (rank == 2) then ! allocate(v2l(bounds(1):bounds(2),bounds(3):bounds(4))) ! call dio_read(rfile,name,v2l,header=header,iret=iret) ! write(*,*)n,name,rank,dtype!,minval(v2l),maxval(v2l) ! call dump_header(header) ! deallocate(v2l) ! else if (rank == 3) then ! allocate(v3l(bounds(1):bounds(2),bounds(3):bounds(4),bounds(5):bounds(6))) ! call dio_read(rfile,name,v3l,header=header,iret=iret) ! write(*,*)n,name,rank,dtype!,minval(v3l),maxval(v3l) ! call dump_header(header) ! deallocate(v3l) ! end if else if (dtype == DIO_CHARACTER) then if (rank == 1) then slen = min(len(v1c),bounds(2)) call dio_read(rfile,name,v1c(1:slen),header=header,iret=iret) write(*,103)n,name,rank,dtype,v1c(1:slen) call dump_header(header) else print *, ' unknown rank for DIO_CHARACTER', rank stop 1 end if 103 format (I3,1X,A,I3,I4,1X,A) else print *, ' unknown dtype ',dtype stop 1 end if end do call dio_close(rfile,iret=iret) call dio_finalize() stop contains subroutine dump_header(header) use wrfheader implicit none integer, dimension(:), intent(in) :: header character(len=32) :: DateStr,VarName,Units,Description,MemoryOrder,Stagger integer :: FieldType character(len=32), dimension(3) :: DimNames integer, dimension(3) :: DomainStart, DomainEnd, PatchStart, PatchEnd integer :: i if (header(1) == 0) return call wrfheader_unpack(header, DateStr=DateStr, & VarName=VarName, & Units=Units, & Description=Description, & FieldType=FieldType, & MemoryOrder=MemoryOrder, & Stagger=Stagger, & DimNames=DimNames, & DomainStart=DomainStart, DomainEnd=DomainEnd, & PatchStart=PatchStart, PatchEnd=PatchEnd & ) ! write(0,'(13A,I2,A,A,A,40I4)') "|",trim(DateStr),"|",trim(VarName),"|",trim(Units), & ! "|",trim(Description),"|",trim(MemoryOrder),"|",trim(Stagger), & ! "|",FieldType,"|",DimNames,"|", & ! DomainStart, DomainEnd,PatchStart, PatchEnd ! end subroutine dump_header end program diodump