Weird Fortran

JohnNichols · ‎05-22-2020

call diagnos ('Can only have ONE forest', 'w', *100)

This comes from some code developed by a good programmer -- but I have never seen *100 before, I do not even know where in the documentation to look for it.

help

mecej4 · ‎05-22-2020

"Alternate returns", see https://software.intel.com/content/www/us/en/develop/documentation/fortran-compiler-developer-guide-and-reference/top/language-reference/program-units-and-procedures/argument-association-in-procedures/alternate-return-arguments.html , and please forget that they existed.

JohnNichols · ‎05-22-2020

I was looking for a bit of background on some parts of this old Fortran program when I ran across this statement

When Fourier submitted a later competition essay in 1811, the committee (which included Lagrange, Laplace, Malus and Legendre, among others) concluded: ...the manner in which the author arrives at these equations is not exempt of difficulties and...his analysis to integrate them still leaves something to be desired on the score of generality and even rigour.

Even Fourier was criticized.

Steve_Lionel · ‎05-22-2020

Also discussed in Doctor Fortran in “Lest Old Acquaintance Be Forgot” (among other obscure features from days gone by)

JohnNichols · ‎05-22-2020

FORTRAN 77 Version 1.30g

I found this note in the code -- any idea where it comes from?

MWind2 · ‎05-22-2020

https://software.intel.com/content/www/us/en/develop/blogs/doctor-fortran-in-lest-old-acquaintance-be-forgot.html

TimP · ‎05-23-2020

Alternate returns were a vendor-dependent extension before F77, so I remember them only as something which had to be fixed before a program could work.

JohnNichols · ‎05-23-2020

Are you saying I have to fix them, there are _________ hundreds of them.

As I go through the code -- it appears to be written for Unix - mainframe at a UNI.

mecej4 · ‎05-23-2020

No, most Fortran compilers (Ifort, certainly) accept and process alternate returns. The presence of alternate returns may become an issue if you attempt to make substantial modifications to the code.

FortranFan · ‎05-23-2020

Nichols, John wrote:
Are you saying I have to fix them, there are _________ hundreds of them.
As I go through the code -- it appears to be written for Unix - mainframe at a UNI.

See this thread in a post at comp.lang.fortran, the other forum that may be worth a consideration for @Nichols, John for general Fortran-related posts.

On alternate returns, as I state there in the context of the Fortran standard, it is "part of the current standard even as the standard marks it an obsolescent feature."

So one doesn't need to necessarily "fix" the code simply on account of the presence of this feature. Any change to the code will be better driven by a plan and design at refactoring the code with a goal toward modernization.

JohnNichols · ‎05-23-2020

Thank you -- I am not trying to make changes to the code, I am just trying to see it running so I can look at the algorithms.

Steve_Lionel · ‎05-23-2020

mwindham wrote:
https://software.intel.com/content/www/us/en/develop/blogs/doctor-fortra...

Please make note of the new "office" for Doctor Fortran: https://stevelionel.com/drfortran

JohnNichols · ‎05-24-2020

!
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++72
!
      subroutine sclmld(n,s,v,z)
      implicit double precision (a-h,o-z)
      dimension v(n),z(n)
      do 100 i=1,n
        z(i)=s*v(i)
  100 continue
      return
      end

Ok so do I laugh or fix it.

JohnNichols · ‎05-24-2020

!
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++72
!
      double precision function d1mach(i)
!***begin prologue  d1mach
!***date written   750101   (yymmdd)
!***revision date  831014   (yymmdd)
!***category no.  r1
!***keywords  machine constants
!***author  fox, p. a., (bell labs)
!           hall, a. d., (bell labs)
!           schryer, n. l., (bell labs)
!***purpose  returns double precision machine dependent constants
!!!!description
!     from the book, "numerical methods and software" by
!                d. kahaner, c. moler, s. nash
!                prentice hall, 1988
!
!
!     d1mach can be used to obtain machine-dependent parameters
!     for the local machine environment.  it is a function
!     subprogram with one (input) argument, and can be called
!     as follows, for example
!
!          d = d1mach(i)
!
!     where i=1,...,5.  the (output) value of d above is
!     determined by the (input) value of i.  the results for
!     various values of i are discussed below.
!
!  double-precision machine constants
!  d1mach( 1) = b!!(emin-1), the smallest positive magnitude.
!  d1mach( 2) = b**emax*(1 - b**(-t)), the largest magnitude.
!  d1mach( 3) = b**(-t), the smallest relative spacing.
!  d1mach( 4) = b**(1-t), the largest relative spacing.
!  d1mach( 5) = log10(b)
!***references  fox p.a., hall a.d., schryer n.l.,*framework for a
!                 portable library*, acm transactions on mathematical
!                 software, vol. 4, no. 2, june 1978, pp. 177-188.
!***routines called  xerror
!***end prologue  d1mach
!
      integer small(4)
      integer large(4)
      integer right(4)
      integer diver(4)
      integer log10(4)
!
      double precision dmach(5)
!
      equivalence (dmach(1),small(1))
      equivalence (dmach(2),large(1))
      equivalence (dmach(3),right(1))
      equivalence (dmach(4),diver(1))
      equivalence (dmach(5),log10(1))
!
      save
!
!
!     machine constants for the cdc cyber 170 series (ftn5).
!
!      data small(1) / o"00604000000000000000" /
!      data small(2) / o"00000000000000000000" /
!
!      data large(1) / o"37767777777777777777" /
!      data large(2) / o"37167777777777777777" /
!
!      data right(1) / o"15604000000000000000" /
!      data right(2) / o"15000000000000000000" /
!
!      data diver(1) / o"15614000000000000000" /
!      data diver(2) / o"15010000000000000000" /
!
!      data log10(1) / o"17164642023241175717" /
!      data log10(2) / o"16367571421742254654" /
!
!     machine constants for the cdc cyber 200 series
!
!     data small(1) / x'9000400000000000' /
!     data small(2) / x'8fd1000000000000' /
!
!     data large(1) / x'6fff7fffffffffff' /
!     data large(2) / x'6fd07fffffffffff' /
!
!     data right(1) / x'ff74400000000000' /
!     data right(2) / x'ff45000000000000' /
!
!     data diver(1) / x'ff75400000000000' /
!     data diver(2) / x'ff46000000000000' /
!
!     data log10(1) / x'ffd04d104d427de7' /
!     data log10(2) / x'ffa17de623e2566a' /
!
!
!     machine constants for the cdc 6000/7000 series.
!
!     data small(1) / 00564000000000000000b /
!     data small(2) / 00000000000000000000b /
!
!     data large(1) / 37757777777777777777b /
!     data large(2) / 37157777777777777777b /
!
!     data right(1) / 15624000000000000000b /
!     data right(2) / 00000000000000000000b /
!
!     data diver(1) / 15634000000000000000b /
!     data diver(2) / 00000000000000000000b /
!
!     data log10(1) / 17164642023241175717b /
!     data log10(2) / 16367571421742254654b /
!
!     machine constants for the cray 1
!
!     data small(1) / 201354000000000000000b /
!     data small(2) / 000000000000000000000b /
!
!     data large(1) / 577767777777777777777b /
!     data large(2) / 000007777777777777774b /
!
!     data right(1) / 376434000000000000000b /
!     data right(2) / 000000000000000000000b /
!
!     data diver(1) / 376444000000000000000b /
!     data diver(2) / 000000000000000000000b /
!
!     data log10(1) / 377774642023241175717b /
!     data log10(2) / 000007571421742254654b /
!
!
!     machine constants for the ibm 360/370 series,
!     the xerox sigma 5/7/9, the sel systems 85/86, and
!     the perkin elmer (interdata) 7/32.
!
!     data small(1),small(2) / z00100000, z00000000 /
!     data large(1),large(2) / z7fffffff, zffffffff /
!     data right(1),right(2) / z33100000, z00000000 /
!     data diver(1),diver(2) / z34100000, z00000000 /
!     data log10(1),log10(2) / z41134413, z509f79ff /
!
!     machine constatns for the ibm pc family (d. kahaner nbs)
!
!ibm      data dmach/2.23d-308,1.79d+308,1.11d-16,2.22d-16,
!ibm     !  0.301029995663981195d0/
!
! For Macintosh 68000 series chip
!
      data dmach/1.0d-300,1.0d+300,1.0d-16,2.0d-16, 0.301029995663981195d0/
!
!     machine constants for the pdp-10 (ka processor).
!
!     data small(1),small(2) / "033400000000, "000000000000 /
!     data large(1),large(2) / "377777777777, "344777777777 /
!     data right(1),right(2) / "113400000000, "000000000000 /
!     data diver(1),diver(2) / "114400000000, "000000000000 /
!     data log10(1),log10(2) / "177464202324, "144117571776 /
!
!     machine constants for the pdp-10 (ki processor).
!
!     data small(1),small(2) / "000400000000, "000000000000 /
!     data large(1),large(2) / "377777777777, "377777777777 /
!     data right(1),right(2) / "103400000000, "000000000000 /
!     data diver(1),diver(2) / "104400000000, "000000000000 /
!     data log10(1),log10(2) / "177464202324, "476747767461 /
!
!
!     machine constants for the sun-3 (includes those with 68881 chip,
!       or with fpa board. also includes sun-2 with sky board. may also
!       work with software floating point on either system.)
!
!      data small(1),small(2) / x'00100000', x'00000000' /
!      data large(1),large(2) / x'7fefffff', x'ffffffff' /
!      data right(1),right(2) / x'3ca00000', x'00000000' /
!      data diver(1),diver(2) / x'3cb00000', x'00000000' /
!      data log10(1),log10(2) / x'3fd34413', x'509f79ff' /
!
!
!     machine constants for vax 11/780
!     (expressed in integer and hexadecimal)
!    !!! the integer format should be ok for unix systems***
!
!     data small(1), small(2) /        128,           0 /
!     data large(1), large(2) /     -32769,          -1 /
!     data right(1), right(2) /       9344,           0 /
!     data diver(1), diver(2) /       9472,           0 /
!     data log10(1), log10(2) /  546979738,  -805796613 /
!
!    !**the hex format below may not be suitable for unix sysyems***
!     data small(1), small(2) / z00000080, z00000000 /
!     data large(1), large(2) / zffff7fff, zffffffff /
!     data right(1), right(2) / z00002480, z00000000 /
!     data diver(1), diver(2) / z00002500, z00000000 /
!     data log10(1), log10(2) / z209a3f9a, zcff884fb /
!
!   machine constants for vax 11/780 (g-floating)
!     (expressed in integer and hexadecimal)
!    !** the integer format should be ok for unix systems***
!
!     data small(1), small(2) /         16,           0 /
!     data large(1), large(2) /     -32769,          -1 /
!     data right(1), right(2) /      15552,           0 /
!     data diver(1), diver(2) /      15568,           0 /
!     data log10(1), log10(2) /  1142112243, 2046775455 /
!
!    !!*the hex format below may not be suitable for unix sysyems***
!     data small(1), small(2) / z00000010, z00000000 /
!     data large(1), large(2) / zffff7fff, zffffffff /
!     data right(1), right(2) / z00003cc0, z00000000 /
!     data diver(1), diver(2) / z00003cd0, z00000000 /
!     data log10(1), log10(2) / z44133ff3, z79ff509f /
!
!
!***first executable statement  d1mach
      if (i .lt. 1  .or.  i .gt. 5)
     1   call diagnos('d1mach --&i out of bounds','f',*901)
!
      d1mach = dmach(i)
901   return
*
      end
c
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++72
c
      subroutine xerror(messg,nmessg,nerr,level)
****begin prologue  xerror
****date written   790801   (yymmdd)
****revision date  870930   (yymmdd)
****category no.  r3c
****keywords  error,xerror package
****author  jones, r. e., (snla)
****purpose  processes an error (diagnostic) message.
****description
*    from the book "numerical methods and software"
*       by  d. kahaner, c. moler, s. nash
*           prentice hall 1988
*     abstract
*        xerror processes a diagnostic message. it is a stub routine
*        written for the book above. actually, xerror is a sophisticated
*        error handling package with many options, and is described
*        in the reference below. our version has the same calling sequence
*        but only prints an error message and either returns (if the
*        input value of abs(level) is less than 2) or stops (if the
*        input value of abs(level) equals 2).
*
*     description of parameters
*      --input--
*        messg - the hollerith message to be processed.
*        nmessg- the actual number of characters in messg.
*                (this is ignored in this stub routine)
*        nerr  - the error number associated with this message.
*                nerr must not be zero.
*                (this is ignored in this stub routine)
*        level - error category.
*                =2 means this is an unconditionally fatal error.
*                =1 means this is a recoverable error.  (i.e., it is
*                   non-fatal if xsetf has been appropriately called.)
*                =0 means this is a warning message only.
*                =-1 means this is a warning message which is to be
*                   printed at most once, regardless of how many
*                   times this call is executed.
*                 (in this stub routine
*                       level=2 causes a message to be printed and then a
*                                         stop.
*                       level<2 causes a message to be printed and then a
*                                         return.
*
*     examples
*        call xerror('smooth -- num was zero.',23,1,2)
*        call xerror('integ  -- less than full accuracy achieved.',
*                    43,2,1)
*        call xerror('rooter -- actual zero of f found before interval f
*    1ully collapsed.',65,3,0)
*        call xerror('exp    -- underflows being set to zero.',39,1,-1)
*
****references  jones r.e., kahaner d.k., "xerror, the slatec error-
*                 handling package", sand82-0800, sandia laboratories,
*                 1982.
****routines called  xerrwv
****end prologue  xerror
      character*(*) messg
****first executable statement  xerror
      call xerrwv(messg,nmessg,nerr,level,0,0,0,0,0.,0.)
      return
      end
c
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++72
c
      subroutine xerrwv(messg,nmessg,nerr,level,ni,i1,i2,nr,r1,r2)
****begin prologue  xerrwv
****date written   800319   (yymmdd)
****revision date  870930   (yymmdd)
****category no.  r3c
****keywords  error,xerror package
****author  jones, r. e., (snla)
****purpose  processes error message allowing 2 integer and two real
*            values to be included in the message.
****description
*    from the book "numerical methods and software"
*       by  d. kahaner, c. moler, s. nash
*           prentice hall 1988
*     abstract
*        xerrwv prints a diagnostic error message.
*        in addition, up to two integer values and two real
*        values may be printed along with the message.
*        a stub routine for the book above. the actual xerrwv is described
*        in the reference below and contains many other options.
*
*     description of parameters
*      --input--
*        messg - the hollerith message to be processed.
*        nmessg- the actual number of characters in messg.
*                (ignored in this stub)
*        nerr  - the error number associated with this message.
*                nerr must not be zero.
*                (ignored in this stub)
*        level - error category.
*                =2 means this is an unconditionally fatal error.
*                =1 means this is a recoverable error.  (i.e., it is
*                   non-fatal if xsetf has been appropriately called.)
*                =0 means this is a warning message only.
*                =-1 means this is a warning message which is to be
*                   printed at most once, regardless of how many
*                   times this call is executed.
*                  (in this stub level=2 causes an error message to be
*                                          printed followed by a stop,
*                                level<2 causes an error message to be
*                                          printed followed by a return.)
*        ni    - number of integer values to be printed. (0 to 2)
*        i1    - first integer value.
*        i2    - second integer value.
*        nr    - number of real values to be printed. (0 to 2)
*        r1    - first real value.
*        r2    - second real value.
*
*     examples
*        call xerrwv('smooth -- num (=i1) was zero.',29,1,2,
*    1   1,num,0,0,0.,0.)
*        call xerrwv('quadxy -- requested error (r1) less than minimum (
*    1r2).,54,77,1,0,0,0,2,errreq,errmin)
*
****references  jones r.e., kahaner d.k., "xerror, the slatec error-
*                 handling package", sand82-0800, sandia laboratories,
*                 1982.
****routines called  (none)
****end prologue  xerrwv
      character*(*) messg
****first executable statement  xerrwv
      write(*,*) messg
      if(ni.eq.2)then
        write(*,*) i1,i2
      elseif(ni.eq.1) then
        write(*,*) i1
      endif
      if(nr.eq.2) then
        write(*,*) r1,r2
      elseif(nr.eq.1) then
        write(*,*) r1
      endif
      if(abs(level).lt.2)return
      stop
      end

This is a new one on me -- how do I fix it for Intel Fortran?

Steve_Lionel · ‎05-24-2020

The only problem I see is that line 147 (DATA) is longer than 72 characters. It needs proper continuation.

Are you getting some other error?

mecej4 · ‎05-24-2020

You can write versions of d1mach, r1mach and i1mach that use the newer intrinsics in F90 and later.

function i1mach(i) result(s)
implicit none
integer*4 :: i,s,im(10)
data im/5,6,7,6,32,4,2,31,2147483647,2/
if(i.lt.1.or.i.gt.10)stop 'I1MACH(arg < 1 or arg > 10)'
s=im(i)
return
end function i1mach

function r1mach(i) result(s)
implicit none
integer i
real s,rm(5)
logical :: beg = .true.
save rm
if(i.lt.1.or.i.gt.5)stop 'R1MACH(arg < 1 or arg > 5)'
if(beg)then
   beg=.false.
   rm(1) = tiny(0.0)
   rm(2) = huge(0.0)
   rm(3) = epsilon(0.0)/2
   rm(4) = epsilon(0.0)
   rm(5) = log10(2.0)
end if
s = rm(i)
return
end function r1mach

function d1mach(i) result(s)
implicit none
integer i
double precision s,dm(5)
logical :: beg = .true.
save dm
if(i.lt.1.or.i.gt.5)stop 'D1MACH(arg < 1 or arg > 5)'
if(beg)then
   beg=.false.
   dm(1) = tiny(0.0d0)
   dm(2) = huge(0.0d0)
   dm(3) = epsilon(0.0d0)/2
   dm(4) = epsilon(0.0d0)
   dm(5) = log10(2.0d0)
end if
s = dm(i)
return
end function d1mach

JohnNichols · ‎05-25-2020

Thanks. The program is written as a DF and Powerstation Windows program using Winmain.

I just want the bare bones algorithms, so unwinding the stuff that is really not needed is not fun.

I have tried Winmain programming and do not like it -- I just do analysis not pretty windows.

JohnNichols · ‎05-25-2020

string = '"'//optfile(1:nchars(optfile))//'" is not an options file'

I have not seen nchars before, it throws an error so I assume it is an old len??

FortranFan · ‎05-25-2020

mecej4 (Blackbelt) wrote:
You can write versions of d1mach, r1mach and i1mach that use the newer intrinsics in F90 and later. ..

Considering the calendar with nearly 30 years post Fortran 90 standard revision, should anyone be rewriting any old code they should consider current Fortran standard and look into using named constant facility and intrinsics as much as possible:

module machine_constants_m

   integer, parameter :: SP = kind(1.0)
   integer, parameter :: DP = kind(1D0)

   real(SP), parameter :: SP2 = 2.0_sp
   real(DP), parameter :: DP2 = 2.0_dp

   integer, parameter :: i1mach(*) = [ 5, 6, 7, 6, 32, 4, 2, 31, 2147483647, 2 ]
   real(SP), parameter :: r1mach(*) = [ tiny(SP2), huge(SP2), epsilon(SP2)/SP2, epsilon(SP2), log10(SP2) ]
   real(DP), parameter :: d1mach(*) = [ tiny(DP2), huge(DP2), epsilon(DP2)/DP2, epsilon(DP2), log10(DP2) ]

end module

Most end-users won't care or notice the difference whether they consume the "values" as constants or as function invocations, but the former should be preferable as compile-time constants:

C:\temp>type p.f90
module machine_constants_m

   integer, parameter :: SP = kind(1.0)
   integer, parameter :: DP = kind(1D0)

   real(SP), parameter :: SP2 = 2.0_sp
   real(DP), parameter :: DP2 = 2.0_dp

   integer, parameter :: i1mach(*) = [ 5, 6, 7, 6, 32, 4, 2, 31, 2147483647, 2 ]
   real(SP), parameter :: r1mach(*) = [ tiny(SP2), huge(SP2), epsilon(SP2)/SP2, epsilon(SP2), log10(SP2) ]
   real(DP), parameter :: d1mach(*) = [ tiny(DP2), huge(DP2), epsilon(DP2)/DP2, epsilon(DP2), log10(DP2) ]

end module

module machine_functions_m

   implicit none

contains

   function i1mach(i) result(s)
      integer*4 :: i,s,im(10)
      data im/5,6,7,6,32,4,2,31,2147483647,2/
      if(i.lt.1.or.i.gt.10)stop 'I1MACH(arg < 1 or arg > 10)'
      s=im(i)
      return
   end function i1mach

   function r1mach(i) result(s)
      integer i
      real s,rm(5)
      logical :: beg = .true.
      save rm
      if(i.lt.1.or.i.gt.5)stop 'R1MACH(arg < 1 or arg > 5)'
      if(beg)then
         beg=.false.
         rm(1) = tiny(0.0)
         rm(2) = huge(0.0)
         rm(3) = epsilon(0.0)/2
         rm(4) = epsilon(0.0)
         rm(5) = log10(2.0)
      end if
      s = rm(i)
      return
   end function r1mach

   function d1mach(i) result(s)
      integer i
      double precision s,dm(5)
      logical :: beg = .true.
      save dm
      if(i.lt.1.or.i.gt.5)stop 'D1MACH(arg < 1 or arg > 5)'
      if(beg)then
         beg=.false.
         dm(1) = tiny(0.0d0)
         dm(2) = huge(0.0d0)
         dm(3) = epsilon(0.0d0)/2
         dm(4) = epsilon(0.0d0)
         dm(5) = log10(2.0d0)
      end if
      s = dm(i)
      return
   end function d1mach
end module

   blk1: block
      use machine_constants_m, only : i1mach, r1mach, d1mach
      print *, "Block 1: With named constants:"
      print *, "i1mach(9) = ", i1mach(9)
      print *, "r1mach(3) = ", r1mach(3)
      print *, "d1mach(3) = ", d1mach(3)
   end block blk1
   print *
   blk2: block
      use machine_functions_m, only : i1mach, r1mach, d1mach
      print *, "Block 2: With run-time functions:"
      print *, "i1mach(9) = ", i1mach(9)
      print *, "r1mach(3) = ", r1mach(3)
      print *, "d1mach(3) = ", d1mach(3)
   end block blk2
end

C:\temp>ifort /standard-semantics /warn:all /stand:f18 p.f90 -o p.exe
Intel(R) Visual Fortran Intel(R) 64 Compiler for applications running on Intel(R) 64, Version 19.1.1.216 Build 20200306
Copyright (C) 1985-2020 Intel Corporation.  All rights reserved.

p.f90(22): warning #6916: Fortran 2018 does not allow this length specification.   [4]
      integer*4 :: i,s,im(10)
--------------^
Microsoft (R) Incremental Linker Version 14.25.28612.0
Copyright (C) Microsoft Corporation.  All rights reserved.

-out:p.exe
-subsystem:console
p.obj

C:\temp>p.exe
 Block 1: With named constants:
 i1mach(9) =  2147483647
 r1mach(3) =  5.9604645E-08
 d1mach(3) =  1.110223024625157E-016

 Block 2: With run-time functions:
 i1mach(9) =  2147483647
 r1mach(3) =  5.9604645E-08
 d1mach(3) =  1.110223024625157E-016

C:\temp>

And some user(s) will appreciate when they try to access a value outside the supported range and the compile-time check with named constants approach helps resolve the issue sooner rather than getting into a run-time error.

JohnNichols · ‎05-25-2020

I agree with you -- this has been interesting -- my minor interest in the COVID data has grown with a large interest in Australia - it is a challenge keeping up with their questions and requests for more analysis.

One of the academic publications included an interesting graph, so I asked the academic a question about the graph. I was kindly sent a matlab file, on running the file it is clearly obvious that MATLAB's rand function is not rand but has patterns, you can see the patterns, you have trouble accepting the results for MC analysis if the rand func is not random.

The only random number generator that works nicely is the BASICA generator, no idea why but it is good.