Just a few remarks:

Brooks_Van_Horn · ‎04-21-2016

I have a simple program:

Program MkCallTree

Implicit None

Character(50) :: Cfile, Dfile
Character(135):: Buffer(5000)
Character(26)::  Progr(20), Csv, P1, P2, P3
Character(76)::  Calling(5000)
Integer(4)::     Ndx = 0, Nd2 = 0, I, Ndxs, Nof

Interface
 Function ToLower (Input_String) Result (Output_String)
     Character(*), Intent(In)     :: Input_String
     Character(Len(Input_String)) :: Output_String
 End Function ToLower
End Interface

   Call System("Dir /B  *.Lst > List")

   Open ( Unit=4,                 &
          File="Calltree.Txt",    &
          Status='replace',       &
          Form='formatted')

   Open ( Unit=8,                 &
          File="List",            &
          Status='old',           &
          Form='formatted')

   Rewind (4)
   Rewind (8)
   Csv = ""
   Ndx = 0

   Do
      Read(8,"(A)",End=999) Cfile
      If (Cfile == "") Go To 999
      I = 1
      Dfile = ""
      Do While(Cfile(I:I) /= '.')
         I = I + 1
      End Do
      Dfile = Cfile(1:I) // "F90"C
      Dfile = ToLower(Dfile)
      Write(4,"(A,5X,A)") "Dfile = ", Dfile

      Open ( Unit=3,         &
          File="Cfile",       &
          Status='old',       &
          Form='formatted')
      Rewind (3)
      Nof = 0
!     Now Read In The Entire Cfile Entry
      Do While (1 == 1)
         Nof = Nof + 1
         Write(4,'(A,I5)') 'nof = ', Nof
         Buffer(Nof) = "                           "C
         Read(3,'(A135)',End=100) Buffer(Nof)
      End Do
 100  Close (3)

      Nof = Nof - 1
      Write (4,'(A,I5)') 'read Nof = ', Nof
      Ndx = 1
      Progr(Ndx) = ToLower(Trim(Buffer(1)(50:75)))
      Ndxs = Nd2

      Write(4,'(A)') "At Stmt No 100"
      Do I = 3, Nof
         If (Buffer(I)(1:4) == "Page") Then
            P3 = ToLower(Buffer(I)(50:75))
            If (Progr(Ndx) /= P3) Then
               Csv = Progr(Ndx)
               Ndx = Ndx + 1
               Progr(Ndx) = P3
               If (Progr(Ndx) == "") Then
                  Progr(Ndx) = Csv
               End If
            End If
            Cycle
         End If
         P1 = ToLower(Trim(Buffer(I)(2:19)))
         P2 = ToLower(Trim(Buffer(I)(29:35)))
         P3 = ToLower(Buffer(I)(50:75))
         Write(4,600) 'progr', Progr(Ndx), Ndx
         Write(4,600) 'p1=',P1
         Write(4,600) 'p2=', P2
 600     Format(A5, 5X, A, I5)
         Write(4,600) 'p3=',P3
         If (P1 == Progr(Ndx)) Then
            Write(4,601) 'p1='
 601        Format(A3, ' Cycle')
            Cycle
         Elseif (P1 == Csv) Then
            Write(4,601) 'csv'
            Cycle
         End If
         Write(4,602) Progr(Ndx), P1
 602     Format ('is ', A, ' /=  ', A)
         If (Progr(Ndx) /= P1) Then
            If (P2 == "Func  ") Then
               Nd2 = Nd2 + 1
               Write(Calling(Nd2),500) Dfile, Progr(Ndx), "Func  ", P1
 500           Format (A20,1X,A20,1X,A6,1X,A)
            Else If (P2 == "Subr  ") Then
               Nd2 = Nd2 + 1
                Write(Calling(Nd2),500) Dfile, Progr(Ndx), "Subr  ", P3
            Else If (P2 == "Module") Then
               Nd2 = Nd2 + 1
               Write(Calling(Nd2),500) Dfile, Progr(Ndx), "Module", P3
            Else If (P2 == "Intrin") Then
               Nd2 = Nd2 + 1
               Write(Calling(Nd2),500) Dfile, Progr(Ndx), "Intrin", P3
            End If
            If (I /= Nd2) Then
               Write(4,"(A)") Calling(Nd2)
            End If
         End If
      End Do
      If (Ndxs == Nd2) Then
         Nd2 = Nd2 + 1
         Write(Calling(Nd2),500) Dfile, Progr(Ndx), "*None*"
      End If
!     Go Process Another Cfile From List On (8)
   End Do
999 Close (8)
   Do I = 1, Nd2
      Write(4,'(A)') Calling(I)
   End Do
   Close (4)

End Program MkCallTree

Function ToLower ( Input_String ) Result ( Output_String )
     Character(*),Intent(In)      :: Input_String
     Character(Len(Input_String)) :: Output_String

     Character(*),Parameter :: Lower_Case = 'abcdefghijklmnopqrstuvwxyz'
     Character(*),Parameter :: Upper_Case = 'abcdefghijklmnopqrstuvwxyz'
     Integer :: I, N

     Output_String = Input_String
     Do I = 1, Len(Output_String)
       ! -- Find Location Of Letter In Upper Case Constant String
       N = Index( Upper_Case, Output_String( I:I ) )
       If ( N /= 0 ) Output_String( I:I ) = Lower_Case( N:N )
     End Do
     N = Index(Lower_Case, Output_String(1:1))
! Capitalize First Letter In String
     If (N /= 0) Output_String(1:1) = Upper_Case(N:N)
     Return
End Function ToLower

And a data file list that the system command produces:

BoxIt.lst
Browse.lst
ClrScreen.lst
DlgChanged.lst
DoColor.lst
DoGraphs.lst
DoGrids.lst
DoHisto.lst
DoInput.lst
DoMoments.lst
DrawIt.lst
FitOut.lst
FitSamp.lst
GetK.lst
GetLength.lst
GetPT.lst
GetRS.lst
GetValue.lst
Heap.lst
Horn.lst
Howe.lst
Integrate.lst
Kolmo.lst
KS.lst
LnGamma.lst
MyHearderOut.lst
MyScreen.lst
MyTextOut.lst
NormalCDF.lst
OnSpinEdit.lst
Pearson.lst
Pearsonglobals.lst
PlotCDF.lst
PlotEDF.lst
PlotHist.lst
PlotPDF.lst
Print.lst
Purge.lst
RadioChanged.lst
RanF.lst
SaveAll.lst
SetupMyDlg.lst
Special.lst
TypeI.lst
TypeII.lst
TypeIII.lst
TypeIV.lst
TypeV.lst
TypeVI.lst
TypeVII.lst
TypeVIII.lst
Van.lst
zData.lst

I read the first entry from list into cfile and create dfile and all goes well until the first read of the .lst file and it jumps to 999. I've put in a lot of debug to unit 4 but that doesn't get printed. I'm at a loss.

Thanks for any suggestion.

Brooks

Brooks_Van_Horn · ‎04-21-2016

It was a stupid mistake. All is working now. Line 48 should not have any "'s around cfile. Plus a few cleanup things had to be changed. The ToLowCase had to be made into a subroutine because the allocation went south on the return value.

Thanks,

Brooks

Arjen_Markus · ‎04-22-2016

Just a few remarks:

Why "F90"C? If it is to mark the end of the significant part of the string, that is failing - the tolower function just takes the whole character length.You could do: DFile = Tolower( cfile(1:i) ) instead
The function tolower does not convert to lower case - the characters in lower_case and upper_case are identical
If you make tolower an internal routine by placing it before the end of the program you have no need for the interface block:

   ...
   close(4)

contains
function tolower( ... )
    ...
end function
end program mycalltree

But I do not understand your comment that tolower had to be turned in a subroutine because of a problem with the allocation. The code does not do any allocation and returning a character string like in the code you posted ought to work fine.

Read fails and debug wont work