! scan_restrt.f90 — varre o RESTRT global gravado pelo quilt server do
! etafcst (RESTRT#######.t00s / .quilt.t00s, layout de QUILT.f90) e:
!   1) INVENTARIA os registros: min/max/NaN de cada campo, tamanhos de
!      registro conferidos com o esperado e diagnostico EXATO de
!      truncamento (em qual registro/campo e offset o arquivo acabou);
!   2) EXTRAI campos escolhidos para um binario "generico" que a
!      plataforma (eta-grid-mapper) le pela opcao "📦 Outro": para cada
!      campo, um registro character*40 com o nome + um registro real*4
!      (IM,JM). Varios campos viram SERIE animavel (barra ⏵ do mapa).
!      Carregue antes o ETAIN da rodada para IM/JM baterem.
!
! Grade E: campos de massa (PD, T, ...) nos pontos H; U/V nos pontos V
! (mesma malha IM×JM, deslocada meia caixa — o dashboard plota por I,J).
!
! Compilar (Intel do cluster ou gfortran local):
!   ifort    -O0 -traceback scan_restrt.f90 -o scan_restrt
!   gfortran -O0 scan_restrt.f90 -o scan_restrt
! Uso:
!   ./scan_restrt ARQ IM JM LM                          # so inventario
!   ./scan_restrt ARQ IM JM LM -v                       # todos os niveis
!   ./scan_restrt ARQ IM JM LM PSLP T:20 U10 -o out.bin # extrai p/ "Outro"
!   ./scan_restrt ARQ IM JM LM T -o T_niveis.bin        # T em TODOS os
!                                                       # niveis => serie
! Variaveis 2D:  PDOMG RESOMG PD RES FIS RSWIN RSWOUT TG Z0 AKMS CZEN
!   AKHS THS QS TWBS QWBS HBOT CFRACL THZ0 QZ0 UZ0 VZ0 USTAR HTOP CFRACM
!   SNO SI CLDEFI RF PSLP CUPPT CFRACH SOILTB SFCEXC SMSTAV SMSTOT GRNFLX
!   PCTSNO RLWIN RADOT CZMEAN SIGT4 U00 LC SR PREC ACPREC ACCLIQ CUPREC
!   ACFRCV NCFRCV ACFRST NCFRST ACSNOW ACSNOM SSROFF BGROFF SFCSHX SFCLHX
!   SUBSHX SNOPCX SFCUVX SFCEVP POTEVP ASWIN ASWOUT ASWTOA ALWIN ALWOUT
!   ALWTOA TH10 Q10 U10 V10 TSHLTR QSHLTR PSHLTR TH100 Q100 U100 V100
!   XMOMFLUX YMOMFLUX CMC ALBEDO POTFLX TLMIN TLMAX MAXWU MAXWV CNVBOT
!   CNVTOP RSWTOA RLWTOA
! Variaveis 3D (use NOME ou NOME:NIVEL):
!   OMGALF T Q U V Q2 TTND CWM TRAIN TCUCN RSWTT RLWTT   (1..LM)
!   SMC STC SH2O                                         (solo, 1..8)
program scan_restrt
  implicit none
  integer, parameter :: NSOIL = 8
  integer :: im, jm, lm, n, l, ia, nargs
  integer(8) :: pos, recpos0, filesz, expsz
  integer(4) :: recbytes
  logical :: ok, verbose, bigend
  integer :: nrec, nfld, nextr, nspec
  character(len=512) :: fname, outfile, arg
  character(len=32) :: spec_nm(64)
  integer :: spec_lv(64)                 ! -1 = todos os niveis
  real(4), allocatable :: f(:)
  character(len=96) :: lastdesc
  ! cabecalho (layout do QUILT.f90)
  logical(4) :: run
  integer(4) :: idat(3), ihrst, ntsd, ihour

  verbose = .false.; nspec = 0; nextr = 0; nrec = 0; nfld = 0
  outfile = 'outro_restrt.bin'
  nargs = command_argument_count()
  if (nargs < 4) then
    write(*,'(a)') 'uso: ./scan_restrt ARQ IM JM LM [-v] [VAR[:NIV] ...] [-o SAIDA]'
    stop
  end if
  call get_command_argument(1, fname)
  call get_command_argument(2, arg); read(arg,*) im
  call get_command_argument(3, arg); read(arg,*) jm
  call get_command_argument(4, arg); read(arg,*) lm
  ia = 5
  do while (ia <= nargs)
    call get_command_argument(ia, arg)
    if (arg == '-v') then
      verbose = .true.
    else if (arg == '-o') then
      ia = ia + 1; call get_command_argument(ia, outfile)
    else
      nspec = nspec + 1
      call parse_spec(arg, spec_nm(nspec), spec_lv(nspec))
    end if
    ia = ia + 1
  end do

  n = im * jm
  allocate(f(n))

  inquire(file=trim(fname), size=filesz)
  if (filesz < 0) stop 'erro: arquivo nao encontrado'
  expsz = expected_size()
  write(*,'(a,i4,a,i4,a,i3)') 'IM=', im, '  JM=', jm, '  LM=', lm
  write(*,'(a,i12,a,i12,a,f6.1,a)') 'tamanho: ', filesz, ' bytes;  esperado: ', &
    expsz, '  (', 100.*real(filesz)/real(expsz), '% do layout completo)'

  ! endianness: 1o marcador deve ser 60 (cab.1). Se for 60 byte-invertido,
  ! reabre com CONVERT (extensao aceita por ifort e gfortran).
  bigend = .false.
  open(10, file=trim(fname), access='stream', form='unformatted', status='old')
  read(10) recbytes
  if (recbytes /= 60 .and. bswap(recbytes) == 60) then
    close(10); bigend = .true.
    open(10, file=trim(fname), access='stream', form='unformatted', &
         status='old', convert='BIG_ENDIAN')
    write(*,'(a)') 'arquivo BIG-ENDIAN: lendo com CONVERT (a saida sera nativa).'
  else if (recbytes /= 60) then
    write(*,'(a,i12,a)') 'AVISO: 1o marcador = ', recbytes, &
      ' (esperado 60). Arquivo nao parece um RESTRT global do quilt.'
  end if
  pos = 1_8; ok = .true.

  if (nspec > 0) open(21, file=trim(outfile), form='unformatted', status='replace')

  ! ---------------- sequencia de registros (QUILT.f90) ----------------
  call rec_hdr1()
  call rec_fields('PDOMG RESOMG')
  do l = 1, lm
    call rec_3d('OMGALF', l)
  end do
  call rec_hdr2()
  call rec_fields('PD RES FIS')
  call rec_boundary()
  do l = 1, lm
    call rec_3d('T', l);     call rec_3d('Q', l);     call rec_3d('U', l)
    call rec_3d('V', l);     call rec_3d('Q2', l);    call rec_3d('TTND', l)
    call rec_3d('CWM', l);   call rec_3d('TRAIN', l); call rec_3d('TCUCN', l)
  end do
  call rec_hdr_fields('RSWIN RSWOUT TG Z0 AKMS CZEN')
  call rec_fields('AKHS THS QS TWBS QWBS HBOT CFRACL')
  call rec_fields('THZ0 QZ0 UZ0 VZ0 USTAR HTOP CFRACM')
  call rec_fields('SNO SI CLDEFI RF PSLP CUPPT CFRACH')
  call rec_fields('SOILTB SFCEXC SMSTAV SMSTOT GRNFLX PCTSNO')
  call rec_fields('RLWIN RADOT CZMEAN SIGT4')
  call rec_u00()
  call rec_hdr_fields('PREC ACPREC ACCLIQ CUPREC')
  call rec_fields('ACFRCV NCFRCV ACFRST NCFRST')
  call rec_fields('ACSNOW ACSNOM SSROFF BGROFF')
  call rec_fields('SFCSHX SFCLHX SUBSHX SNOPCX SFCUVX SFCEVP POTEVP')
  call rec_fields('ASWIN ASWOUT ASWTOA ALWIN ALWOUT ALWTOA')
  call rec_scal5()
  call rec_fields('TH10 Q10 U10 V10 TSHLTR QSHLTR PSHLTR TH100 Q100 U100 V100 XMOMFLUX YMOMFLUX')
  call rec_soil('SMC')
  call rec_fields('CMC')
  call rec_soil('STC')
  call rec_soil('SH2O')
  call rec_fields('ALBEDO')
  call rec_tail()
  do l = 1, lm
    call rec_3d('RSWTT', l); call rec_3d('RLWTT', l)
  end do
  call rec_fields('CNVBOT')
  call rec_fields('CNVTOP')
  call rec_fields('RSWTOA')
  call rec_fields('RLWTOA')
  ! ---------------------------------------------------------------------

  if (ok) then
    if (pos - 1 < filesz) then
      write(*,'(/a,i12,a)') 'AVISO: sobraram ', filesz - (pos-1), &
        ' bytes apos o ultimo registro esperado (versao com campos extras?).'
    else
      write(*,'(/a,i6,a,i8,a)') 'arquivo COMPLETO: ', nrec, ' registros, ', &
        nfld, ' campos lidos.'
    end if
  end if
  close(10)

  if (nspec > 0) then
    close(21)
    write(*,'(/a,i5,a)') 'extraidos ', nextr, ' campo(s) -> '//trim(outfile)
    if (nextr == 0) then
      write(*,'(a)') 'NENHUM campo casou com o pedido (confira nomes/niveis acima).'
    else
      write(*,'(a)') 'na plataforma: carregue o ETAIN da rodada e o arquivo em "📦 Outro";'
      write(*,'(a)') 'varios campos viram SERIE nomeada (anime/alterne na barra ⏵ do mapa).'
    end if
  end if

contains

  integer(4) function bswap(x)
    integer(4), intent(in) :: x
    bswap = ior(ior(ishft(iand(x, int(z'FF',4)), 24),                       &
                    ishft(iand(x, int(z'FF00',4)), 8)),                     &
                ior(iand(ishft(x, -8), int(z'FF00',4)),                     &
                    iand(ishft(x, -24), int(z'FF',4))))
  end function bswap

  integer(8) function expected_size()
    integer(8) :: n4, lb
    n4 = 4_8 * n
    lb = 2*im + jm - 3                       ! pontos de contorno (grade E)
    expected_size = (60_8+8) + (2*n4+8) + lm*(n4+8) + (72_8+8) + (3*n4+8)   &
      + ((2*lb + 12*lb*lm)*4 + 8) + 9_8*lm*(n4+8)                           &
      + (60_8+6*n4+8) + 3*(7*n4+8) + (6*n4+8) + (4*n4+8)                    &
      + ((3*n+2*lm)*4_8 + 8) + (60_8+4*n4+8) + 2*(4*n4+8) + (7*n4+8)        &
      + (6*n4+8) + (20_8+8) + (13*n4+8)                                     &
      + 3*(NSOIL*n4+8) + 2*(n4+8)                                           &
      + (5*n4 + 13*4_8 + 8) + 2_8*lm*(n4+8) + 4*(n4+8)
  end function expected_size

  subroutine parse_spec(s, nm, lv)
    character(*), intent(in)  :: s
    character(*), intent(out) :: nm
    integer, intent(out)      :: lv
    integer :: p
    p = index(s, ':')
    if (p > 0) then
      nm = s(1:p-1); read(s(p+1:), *) lv
    else
      nm = s; lv = -1
    end if
    call upcase(nm)
  end subroutine parse_spec

  subroutine upcase(s)
    character(*), intent(inout) :: s
    integer :: i, c
    do i = 1, len_trim(s)
      c = iachar(s(i:i))
      if (c >= iachar('a') .and. c <= iachar('z')) s(i:i) = achar(c-32)
    end do
  end subroutine upcase

  ! ---- registro: abre (marcador inicial) / fecha (marcador final) ----
  subroutine openrec(desc, expbytes)
    character(*), intent(in) :: desc
    integer(8), intent(in)   :: expbytes    ! <0: nao confere
    integer :: ios
    if (.not. ok) return
    lastdesc = desc
    read(10, pos=pos, iostat=ios) recbytes
    if (ios /= 0) then
      call truncated('antes do registro'); return
    end if
    recpos0 = pos + 4; pos = recpos0
    nrec = nrec + 1
    if (expbytes >= 0 .and. int(recbytes,8) /= expbytes) &
      write(*,'(a,i12,a,i12,a)') 'AVISO ['//trim(desc)//']: registro de ', &
        int(recbytes,8), ' bytes; esperado ', expbytes, ' (IM/JM/LM conferem?)'
  end subroutine openrec

  subroutine closerec()
    integer(4) :: m2
    integer :: ios
    if (.not. ok) return
    pos = recpos0 + int(recbytes,8)
    read(10, pos=pos, iostat=ios) m2
    if (ios /= 0) then
      call truncated('no fim do registro'); return
    end if
    if (m2 /= recbytes) write(*,'(a,i12,a,i12)') &
      'AVISO ['//trim(lastdesc)//']: marcador final ', m2, ' != inicial ', recbytes
    pos = pos + 4
  end subroutine closerec

  subroutine truncated(onde)
    character(*), intent(in) :: onde
    ok = .false.
    write(*,'(/a)') '*** ARQUIVO TRUNCADO '//onde//' ['//trim(lastdesc)//'] ***'
    write(*,'(a,i12,a,i12,a,f6.1,a)') '    offset ', pos-1, ' de ', filesz, &
      ' bytes  (', 100.*real(filesz)/real(expsz), '% do esperado)'
    write(*,'(a,i6,a,i8,a)') '    lidos ate aqui: ', nrec, ' registros, ', nfld, ' campos.'
  end subroutine truncated

  ! ---- le um campo (IM,JM) do registro corrente: estatistica + extracao ----
  subroutine getf(vname, lv, lvmax, show)
    character(*), intent(in) :: vname
    integer, intent(in)      :: lv, lvmax   ! lv=0: 2D; senao nivel/camada
    logical, intent(in)      :: show
    integer :: ios, nbad, nnan
    character(len=40) :: nm40
    if (.not. ok) return
    if (pos + 4_8*n - 1 > recpos0 + int(recbytes,8)) then
      write(*,'(a)') 'AVISO ['//trim(lastdesc)//']: campo '//trim(vname)// &
        ' nao cabe no registro — pulando.'
      return
    end if
    read(10, pos=pos, iostat=ios) f
    if (ios /= 0) then
      lastdesc = trim(lastdesc)//' / campo '//trim(vname)
      call truncated('dentro do campo'); return
    end if
    pos = pos + 4_8*n
    nfld = nfld + 1
    nnan = count(f /= f)
    nbad = nnan + count(abs(f) > 1.e30)
    if (show .or. verbose .or. nbad > 0 .or. lv <= 1 .or. lv == lvmax) then
      if (lv > 0) then
        write(*,'(a10,a,i3.3,a,2es14.6,a,i8,a,i8)') adjustl(vname), ':', lv, &
          '  min/max:', minval(f), maxval(f), '  NaN:', nnan, '  |x|>1e30:', nbad-nnan
      else
        write(*,'(a14,a,2es14.6,a,i8,a,i8)') adjustl(vname), &
          '  min/max:', minval(f), maxval(f), '  NaN:', nnan, '  |x|>1e30:', nbad-nnan
      end if
    end if
    if (nspec > 0) then
      if (wanted(vname, lv)) then
        if (lv > 0) then
          write(nm40,'(a,a,i3.3)') trim(vname), ' l=', lv
        else
          nm40 = vname
        end if
        write(21) nm40
        write(21) f
        nextr = nextr + 1
      end if
    end if
  end subroutine getf

  logical function wanted(vname, lv)
    character(*), intent(in) :: vname
    integer, intent(in)      :: lv
    character(len=32) :: up
    integer :: k
    up = vname; call upcase(up)
    wanted = .false.
    do k = 1, nspec
      if (trim(spec_nm(k)) == trim(up) .and. &
          (spec_lv(k) == -1 .or. spec_lv(k) == lv)) then
        wanted = .true.; return
      end if
    end do
  end function wanted

  ! ---- tipos de registro ----
  subroutine rec_fields(names)          ! so campos (IM,JM), separados por espaco
    character(*), intent(in) :: names
    call rec_generic(names, 0_8, 0_8)
  end subroutine rec_fields

  subroutine rec_hdr_fields(names)      ! cab. 60 bytes (RUN..LABEL,IHOUR) + campos
    character(*), intent(in) :: names
    call rec_generic(names, 60_8, 0_8)
  end subroutine rec_hdr_fields

  subroutine rec_generic(names, hdrbytes, tailbytes)
    character(*), intent(in) :: names
    integer(8), intent(in)   :: hdrbytes, tailbytes
    integer :: i0, i1, nf
    if (.not. ok) return
    nf = 1
    do i0 = 1, len_trim(names)
      if (names(i0:i0) == ' ') nf = nf + 1
    end do
    call openrec(names, hdrbytes + int(nf,8)*4_8*n + tailbytes)
    if (.not. ok) return
    pos = pos + hdrbytes
    i0 = 1
    do
      i1 = index(names(i0:), ' ')
      if (i1 == 0) then
        call getf(names(i0:), 0, 0, .true.); exit
      end if
      call getf(names(i0:i0+i1-2), 0, 0, .true.)
      if (.not. ok) return
      i0 = i0 + i1
    end do
    call closerec()
  end subroutine rec_generic

  subroutine rec_3d(vname, lv)          ! um registro = um nivel de var 3D
    character(*), intent(in) :: vname
    integer, intent(in)      :: lv
    if (.not. ok) return
    call openrec(trim(vname)//' (nivel)', 4_8*n)
    if (.not. ok) return
    call getf(vname, lv, lm, .false.)
    call closerec()
  end subroutine rec_3d

  subroutine rec_soil(vname)            ! NSOIL camadas num registro so
    character(*), intent(in) :: vname
    integer :: k
    if (.not. ok) return
    call openrec(trim(vname)//' (solo)', int(NSOIL,8)*4_8*n)
    if (.not. ok) return
    do k = 1, NSOIL
      call getf(vname, k, NSOIL, .false.)
      if (.not. ok) return
    end do
    call closerec()
  end subroutine rec_soil

  subroutine rec_hdr1()                 ! RUN,IDAT,IHRST,NTSD,LABEL,IHOUR
    character(len=32) :: label
    integer :: ios
    call openrec('cab.1 RUN,IDAT,IHRST,NTSD,LABEL,IHOUR', 60_8)
    if (.not. ok) return
    read(10, pos=pos, iostat=ios) run, idat, ihrst, ntsd, label, ihour
    if (ios /= 0) then
      call truncated('dentro do cab.1'); return
    end if
    write(*,'(a,i2.2,a,i2.2,a,i4,a,i2.2,a,i8,a,i7)') 'data: ', idat(2), '/', &
      idat(1), '/', idat(3), ' ', ihrst, 'Z   ntsd=', ntsd, '  ihour=', ihour
    write(*,'(a)') 'label: "'//trim(label)//'"'
    call closerec()
  end subroutine rec_hdr1

  subroutine rec_hdr2()                 ! cab.2 + FIRST,IOUT,NSHDE
    call openrec('cab.2 RUN..IHOUR,FIRST,IOUT,NSHDE', 72_8)
    if (.not. ok) return
    call closerec()
  end subroutine rec_hdr2

  subroutine rec_boundary()             ! PDB,TB,QB,UB,VB,Q2B,CWMB — so confere
    integer(8) :: lb
    lb = 2*im + jm - 3
    call openrec('contorno PDB..CWMB', (2*lb + 12*lb*lm)*4_8)
    if (.not. ok) return
    call closerec()
  end subroutine rec_boundary

  subroutine rec_u00()                  ! U00, UL(2*LM), LC, SR
    if (.not. ok) return
    call openrec('U00,UL,LC,SR', (3_8*n + 2*lm)*4_8)
    if (.not. ok) return
    call getf('U00', 0, 0, .true.)
    pos = pos + 2_8*lm*4_8              ! UL(2*LM): obsoleto, pula
    call getf('LC', 0, 0, .true.)
    call getf('SR', 0, 0, .true.)
    call closerec()
  end subroutine rec_u00

  subroutine rec_scal5()                ! ARDSW,ARDLW,ASRFC,AVRAIN,AVCNVC
    real(4) :: s(5)
    integer :: ios
    call openrec('escalares ARDSW..AVCNVC', 20_8)
    if (.not. ok) return
    read(10, pos=pos, iostat=ios) s
    if (ios /= 0) then
      call truncated('nos escalares'); return
    end if
    write(*,'(a,5es13.5)') 'ARDSW,ARDLW,ASRFC,AVRAIN,AVCNVC:', s
    call closerec()
  end subroutine rec_scal5

  subroutine rec_tail()                 ! POTFLX..MAXWV + escalares finais
    real(4) :: acutim, aratim, aphtim, tph0d, tlm0d
    integer(4) :: ints(7)
    logical(4) :: lrst
    integer :: ios
    call openrec('POTFLX,TLMIN,TLMAX,MAXWU,MAXWV+escalares', 5_8*4_8*n + 13*4_8)
    if (.not. ok) return
    call getf('POTFLX', 0, 0, .true.)
    call getf('TLMIN' , 0, 0, .true.)
    call getf('TLMAX' , 0, 0, .true.)
    call getf('MAXWU' , 0, 0, .true.)
    call getf('MAXWV' , 0, 0, .true.)
    if (.not. ok) return
    read(10, pos=pos, iostat=ios) acutim, aratim, aphtim, ints, tph0d, tlm0d, lrst
    if (ios == 0) then
      write(*,'(a,3es13.5)') 'ACUTIM,ARATIM,APHTIM:', acutim, aratim, aphtim
      write(*,'(a,7i8)')     'NHEAT,NPHS,NCNVC,NPREC,NRDSW,NRDLW,NSRFC:', ints
      write(*,'(a,2f10.3,a,l2)') 'TPH0D,TLM0D:', tph0d, tlm0d, '   RESTRT=', lrst
    end if
    call closerec()
  end subroutine rec_tail

end program scan_restrt