MODULE nagfmcheck
  USE iso_c_binding,ONLY:c_int ! ,c_null_ptr
  PRIVATE
  INTEGER(c_int),BIND(C,NAME='__NAGf90_SUPPRESS_PAUSE_ON_EXIT'),PUBLIC :: nopause
!
! Private parameters for 32-bit and 64-bit integers.
!
  INTEGER,PARAMETER,PRIVATE :: int64 = SELECTED_INT_KIND(18)
!
! The mtrace item numbers are now 64-bit integers.
!
  INTEGER,PARAMETER,PUBLIC :: number_k = int64
!
! In order to run a 32-bit nagfmcheck on a 64-bit system,
! always select 64-bit integers to use for addresses and sizes.
!
  INTEGER,PARAMETER,PUBLIC :: addr_k = int64
END MODULE
PROGRAM nagfmcheck_program
  USE nagfmcheck
!
! Copyright 2003-2016 The Numerical Algorithms Group Ltd., Oxford, U.K.
!
! Analyse results from -mtrace option to the NAG Fortran Compiler.
!
! Malcolm Cohen, October 2001
!
! Revised for Release 5.
!
! Further revised for Release 5.1.
!
! Release 4.4: 1.3, 04/09/02
!
! Release 5.1: 1.3, 06/07/28
!
! Release 5.2: nagfmcheck.f90 1 2009-12-02 02:54:28Z Malcolm Cohen
!
! Release 5.3: nagfmcheck.f90 2782 2013-03-22 06:45:39Z Malcolm Cohen
!
! Hibiya: nagfmcheck.f90 3557 2014-04-17 00:42:11Z Malcolm Cohen
!
! Tozai: $Id: nagfmcheck.f90 5248 2016-06-28 00:08:30Z Malcolm Cohen $
!
! Inspired by Anthony Cole's tf_summary program (in C).
!
! This version usually reads from stdin and writes to stdout.
! However, it can also read from other files...
!
  USE iso_fortran_env,ONLY:input_unit,output_unit,error_unit
  IMPLICIT NONE
!
! The type for tracking allocations.
!
  TYPE alloc_record
    TYPE(alloc_record),POINTER :: next,prev
    INTEGER(number_k) number
    INTEGER(addr_k) size,address
    INTEGER lineno
    CHARACTER(200) filename
  END TYPE
!
! Now only handles release 5 of the tracing allocator.
!
  TYPE(alloc_record),POINTER :: first=>NULL(),last=>NULL()
!
! We keep track of allocations in a doubly linked list.
! The list is searched backwards!
! With stack-like allocations, this will be quick.
!
  TYPE(alloc_record),POINTER :: deallocated=>NULL()
!
! Deallocated records are placed onto the deallocated list.
! Provides more interesting output with multiple deallocations.
!
  CHARACTER(250) line
  INTEGER(number_k) :: number_expected = 1
!
! Files etc.
!
  INTEGER input,output,argn,arglen
  CHARACTER(200) errmsg
  CHARACTER(:),ALLOCATABLE :: arg,tmp
  INTRINSIC COMMAND_ARGUMENT_COUNT,GET_COMMAND_ARGUMENT
!
! Statistics
!
  INTEGER :: unrecognised_line = 0
  INTEGER :: allocation_failures = 0
  INTEGER(number_k) :: reallocations = 0
  INTEGER :: reallocation_failures = 0
!
! Initialisation
!
  input = INPUT_UNIT
  output = OUTPUT_UNIT
  nopause = 42
  DO argn=1,COMMAND_ARGUMENT_COUNT()
    CALL GET_COMMAND_ARGUMENT(argn,LENGTH=arglen)
    IF (arglen==0) STOP '?Zero-length argument - use /HELP for help'
    ALLOCATE(CHARACTER(arglen)::arg)
    CALL GET_COMMAND_ARGUMENT(argn,arg)
    IF (arglen>12) THEN
      IF (arg(:12)=='C:/msys/1.0/') THEN
        !
        ! Not-very-clever MSYS trickery... fix it up.
        !
        ALLOCATE(tmp,SOURCE=arg(12:))
        DEALLOCATE(arg)
        ALLOCATE(arg,SOURCE=tmp)
        DEALLOCATE(tmp)
      END IF
    END IF
    IF (arg(1:1)/='-' .AND. arg(1:1)/='/') THEN
      WRITE (error_unit,*) 'Use /HELP for help.'
      STOP '?Argument does not begin with option character'
    ELSE IF (str_eq_nocase(arg(2:),'H') .OR. str_eq_nocase(arg(2:),'HELP')) THEN
      PRINT *,'To run as a filter, run with no arguments.'
      PRINT *,'Options are:'
      IF (arg(1:1)=='/') THEN
        PRINT *,'  /HELP                Display this message'
        PRINT *,'  /INPUT=infilename    Read from infilename instead of stdin'
        PRINT *,'  /OUTPUT=outfilename  Write to outfilename instead of stdout'
      ELSE
        PRINT *,'  -help                Display this message'
        PRINT *,'  -input=infilename    Read from infilename instead of stdin'
        PRINT *,'  -output=outfilename  Write to outfilename instead of stdout'
      END IF
      STOP 'End of help.'
    ELSE IF (str_eq_nocase(arg(2:MIN(7,arglen)),'INPUT=')) THEN
      IF (input/=INPUT_UNIT) THEN
        WRITE (error_unit,*) '?Multiple ',arg(:7),' options specified'
        STOP '?Duplicate input option'
      END IF
      OPEN(17,FILE=arg(8:),STATUS='OLD',FORM='FORMATTED',IOMSG=errmsg,ERR=997)
      input = 17
    ELSE IF (str_eq_nocase(arg(2:MIN(8,arglen)),'OUTPUT=')) THEN
      IF (output/=OUTPUT_UNIT) THEN
        WRITE (error_unit,*) '?Multiple ',arg(:8),' options specified'
        STOP '?Duplicate output option'
      END IF
      OPEN(18,FILE=arg(9:),STATUS='NEW',FORM='FORMATTED',IOMSG=errmsg,ERR=998)
      output = 18
    ELSE
      WRITE (error_unit,*) '?Unrecognised argument "',arg,'"'
      STOP '?Unrecognised argument'
    END IF
    DEALLOCATE(arg)
  END DO
!
! The action
!
  DO
    READ (input,1,END=4,ERR=999,IOMSG=errmsg) line
1   FORMAT(A)
    IF (line(1:1)=='[') CALL process(line)
  END DO
4 CONTINUE
  CALL print_summary
  STOP
997 WRITE (error_unit,*) 'Cannot open input file: ',TRIM(errmsg)
  STOP '?Input file open error'
998 WRITE (error_unit,*) 'Cannot open output file: ',TRIM(errmsg)
  STOP '?Output file open error'
999 WRITE (error_unit,*) 'I/O input error: ',TRIM(errmsg)
  STOP '?I/O input error'
CONTAINS
  SUBROUTINE print_summary
    TYPE(alloc_record),POINTER :: p
    IF (unrecognised_line>0) &
      WRITE (output,*) '***',unrecognised_line,'unrecognised lines'
    WRITE (output,*) number_expected-1,'allocations'
    IF (allocation_failures>0) &
      WRITE (output,*) allocation_failures,'allocation failures'
    IF (reallocations>0) &
      WRITE (output,*) reallocations,'reallocations'
    IF (reallocation_failures>0) &
      WRITE (output,*) reallocation_failures,'reallocation failures'
    IF (.NOT.ASSOCIATED(first)) THEN
      WRITE (output,*) 'No memory leaked'
    ELSE
      WRITE (output,*) '***MEMORY LEAK:'
      p => first
      DO
        CALL show_record(p,'LEAK:')
        p => p%next
        IF (.NOT.ASSOCIATED(p)) EXIT
      END DO
    END IF
  END SUBROUTINE
  SUBROUTINE show_record(rec,label)
    TYPE(alloc_record),INTENT(IN) :: rec
    CHARACTER(*) label
    WRITE (output,1,ADVANCE='NO') label,rec%number
1   FORMAT(1X,A,' Allocation ',I0)
    IF (rec%size>0) THEN
      WRITE (output,2,ADVANCE='NO') rec%size
2     FORMAT(' (size ',I0,')')
    END IF
    IF (rec%address>0) THEN
      WRITE (output,3,ADVANCE='NO') rec%address
3     FORMAT(" = Z'",Z0,"'")
    END IF
    IF (rec%lineno>0) THEN
      WRITE (output,4,ADVANCE='NO') rec%lineno,TRIM(rec%filename)
4     FORMAT(" at line ",I0," of ",A)
    END IF
    WRITE (output,*)
  END SUBROUTINE
  SUBROUTINE deallocate(number,size,address,lineno,filename)
    INTEGER(number_k),INTENT(IN) :: number
    INTEGER(addr_k),INTENT(IN) :: size,address
    INTEGER,INTENT(IN) :: lineno
    CHARACTER(*),INTENT(IN) :: filename
    TYPE(alloc_record),POINTER :: p
    p => last
    DO WHILE(ASSOCIATED(p))
      IF (p%number==number) EXIT
      p => p%prev
    END DO
    IF (ASSOCIATED(p)) THEN
      ! Unlink from allocation list
      IF (ASSOCIATED(p,first)) first => p%next
      IF (ASSOCIATED(p,last)) last => p%prev
      IF (ASSOCIATED(p%next)) p%next%prev => p%prev
      IF (ASSOCIATED(p%prev)) p%prev%next => p%next
      ! Link into deallocation list
      p%next => deallocated
      deallocated => p%next
    ELSE
      p => deallocated
      DO WHILE(ASSOCIATED(p))
        IF (p%number==number) EXIT
        p => p%next
      END DO
      IF (ASSOCIATED(p)) THEN
        WRITE (output,10,ADVANCE='NO') p%number
10      FORMAT(1X,'DEALLOCATE: record ',I0,' already deallocated')
        IF (lineno>0) WRITE (output,4,ADVANCE='NO') lineno,TRIM(filename)
        WRITE (output,8)
      END IF
    END IF
    IF (.NOT.ASSOCIATED(p)) THEN
      WRITE (output,1,ADVANCE='NO') number
1     FORMAT(1X,'DEALLOCATE: record ',I0)
      IF (size>=0) WRITE (output,2,ADVANCE='NO') size
2     FORMAT(' (size ',I0,')')
      IF (address>0) WRITE (output,3,ADVANCE='NO') address
3     FORMAT(" = Z'",Z0,"'")
      IF (lineno>0) WRITE (output,4,ADVANCE='NO') lineno,TRIM(filename)
4     FORMAT(' at line ',I0,' of ',A)
      WRITE (output,5)
5     FORMAT(' NOT FOUND')
    ELSE
      IF (size>=0 .AND. p%size>=0 .AND. size/=p%size) &
        WRITE (output,6,ADVANCE='NO') number,p%size,size
6     FORMAT(1X,'DEALLOCATE: record ',I0,' WRONG SIZE (allocate=',I0, &
             ', deallocate=',I0,')')
      IF (address>0 .AND. p%address>0 .AND. address/=p%address) &
        WRITE (output,7,ADVANCE='NO') number,p%address,address
7     FORMAT(1X,'DEALLOCATE: record ',I0," WRONG ADDRESS (allocate=Z'",Z0, &
             "', deallocate=Z'",Z0,"')")
      IF (size>=0 .AND. p%size>=0 .AND. size/=p%size .OR. &
          address>0 .AND. p%address>0 .AND. address/=p%address) THEN
        IF (lineno>0) THEN
          WRITE (output,4) lineno,TRIM(filename)
        ELSE
          WRITE (output,8)
8         FORMAT()
        END IF
      END IF
    END IF
  END SUBROUTINE
  SUBROUTINE allocate(number,size,address,lineno,filename)
    INTEGER(number_k),INTENT(IN) :: number
    INTEGER(addr_k),INTENT(IN) :: size,address
    INTEGER,INTENT(IN) :: lineno
    CHARACTER(*),INTENT(IN) :: filename
    TYPE(alloc_record),POINTER :: p
    IF (number/=number_expected) THEN
      WRITE (output,*) '***Expected',number_expected,'found',number
      STOP 'FAIL: -mtrace output is bogus'
    END IF
    number_expected = number_expected + 1
    ALLOCATE(p)
    p%number = number
    p%size = size
    p%address = address
    IF (lineno>0) THEN
      p%lineno = lineno
      p%filename = filename
    ELSE
      p%lineno = -1
    END IF
    NULLIFY(p%next)
    p%prev => last
    IF (ASSOCIATED(last)) last%next => p
    last => p
    IF (.NOT.ASSOCIATED(first)) first => p
  END SUBROUTINE
  SUBROUTINE reallocate(number,size,size2,address,address2,lineno,filename)
    INTEGER(number_k),INTENT(IN) :: number
    INTEGER(addr_k),INTENT(IN) :: size,size2,address,address2
    INTEGER,INTENT(IN) :: lineno
    CHARACTER(*),INTENT(IN) :: filename
    TYPE(alloc_record),POINTER :: p
    reallocations = reallocations + 1
    p => last
    DO WHILE(ASSOCIATED(p))
      IF (p%number==number) EXIT
      p => p%prev
    END DO
    IF (.NOT.ASSOCIATED(p)) THEN
      WRITE (output,1,ADVANCE='NO')
1     FORMAT(1X,'REALLOCATE')
      IF (lineno>0) WRITE (output,2) lineno,TRIM(filename)
2     FORMAT(' at line ',I0,' of ',A)
      WRITE (output,3) number
3     FORMAT(': record ',I0,' not found')
    ELSE
      IF (p%size/=size .OR. p%address/=address) THEN
        WRITE (output,1,ADVANCE='NO')
        IF (lineno>0) WRITE (output,2) lineno,TRIM(filename)
        WRITE (output,4) number,p%size,size,p%address,address
4       FORMAT(': record ',I0,' WRONG DETAILS',/, &
               4X,'(allocate size=',I0,', reallocate thought it was=',I0,/, &
               4X,' allocate addr=Z"',Z8.8,'", reallocate thought it was=Z"', &
               Z8.8,'")')
      END IF
      p%size = size2
      p%address = address2
    END IF
  END SUBROUTINE
  SUBROUTINE process(line)
    CHARACTER(*) line
    INTEGER(number_k) number
    INTEGER(addr_k) size,address,size2,address2
    INTEGER pos,lineno
    CHARACTER(200) filename
    pos = INDEX(line,']') - 1
    IF (pos<10) THEN
      unrecognised_line = unrecognised_line + 1
    ELSE IF (line(2:16)=='Allocated item ') THEN
      READ (line(17:pos),*) number
      size = integer_value(line,"(size ")
      address = address_value(line," = Z'")
      CALL get_line_info(line,lineno,filename)
      CALL allocate(number,size,address,lineno,filename)
    ELSE IF (line(2:12)=='Allocation ' .AND. &
             (INDEX(line(13:),'failed]')>0 .OR. &
              INDEX(line(13:),'failed - memory limit')>0)) THEN
      allocation_failures = allocation_failures + 1
    ELSE IF (line(2:17)=='Deallocated item ') THEN
      READ (line(18:pos),*) number
      size = integer_value(line,"(size ")
      address = address_value(line," at Z'")
      CALL get_line_info(line,lineno,filename)
      CALL deallocate(number,size,address,lineno,filename)
    ELSE IF (line(2:17)=='Reallocated item ') THEN
      READ (line(18:pos),*) number
      size = integer_value(line,"from size ")
      address = address_value(line,"(at Z'")
      address2 = address_value(line,"= Z'")
      size2 = integer_value(line," to ")
      CALL get_line_info(line,lineno,filename)
      CALL reallocate(number,size,size2,address,address2,lineno,filename)
    ELSE IF (line(2:21)=='Reallocation of item ') THEN
      reallocation_failures = reallocation_failures + 1
    ELSE
      unrecognised_line = unrecognised_line + 1
    END IF
  END SUBROUTINE
  INTEGER(addr_k) FUNCTION integer_value(line,after)
    CHARACTER(*),INTENT(IN) :: line,after
    INTEGER pos,pos2
    pos = INDEX(line,after)
    IF (pos>0) THEN
      pos2 = VERIFY(line(pos+LEN(after):),'0123456789') - 2
      READ (line(pos+LEN(after):pos+LEN(after)+pos2),*) integer_value
    ELSE
      integer_value = -1
    END IF
  END FUNCTION
  INTEGER(addr_k) FUNCTION address_value(line,after)
    CHARACTER(*),INTENT(IN) :: line,after
    INTEGER pos,pos2
    CHARACTER(6) fmt
    pos = INDEX(line,after)
    IF (pos>0) THEN
      pos2 = VERIFY(line(pos+LEN(after):),'0123456789ABCDEF') - 1
      WRITE (fmt,100) pos2
100   FORMAT("(Z",I0,")")
      READ (line(pos+LEN(after):),fmt) address_value
    ELSE
      address_value = 0
    END IF
  END FUNCTION
  SUBROUTINE get_line_info(line,lineno,filename)
    CHARACTER(*),INTENT(IN) :: line
    INTEGER,INTENT(OUT) :: lineno
    CHARACTER(*),INTENT(OUT) :: filename
    INTEGER pos,pos2
    pos = INDEX(line,"at line ")
    IF (pos>0) THEN
      pos2 = VERIFY(line(pos+8:),'0123456789') - 1
      READ (line(pos+8:pos+8+pos2),*) lineno
      pos = INDEX(line," of ") + 4
      pos2 = SCAN(line(pos:),' ]') - 2
      filename = line(pos:pos+pos2)
    ELSE
      lineno = 0
    END IF
  END SUBROUTINE
  LOGICAL FUNCTION str_eq_nocase(a,b)
    CHARACTER(*),INTENT(IN) :: a,b
    INTEGER i
    CHARACTER c1,c2
    INTRINSIC LEN
    str_eq_nocase = .FALSE.
    IF (LEN(a)/=LEN(b)) RETURN
    DO i=1,LEN(a)
      IF (a(i:i)/=b(i:i)) THEN
        c1 = a(i:i)
        IF (c1>='a' .AND. c1<='z') c1 = ACHAR(IACHAR(c1)+IACHAR('A')-IACHAR('a'))
        c2 = b(i:i)
        IF (c2>='a' .AND. c2<='z') c2 = ACHAR(IACHAR(c2)+IACHAR('A')-IACHAR('a'))
        IF (c1/=c2) RETURN
      END IF
    END DO
    str_eq_nocase = .TRUE.
  END FUNCTION
END
