[ previous ] [ Contents ] [ 1 ] [ 2 ] [ 3 ] [ 4 ] [ 5 ] [ 6 ] [ 7 ] [ 8 ] [ 9 ] [ 10 ] [ 11 ] [ 12 ] [ 13 ] [ next ]


Fortran 90 Lessons for Computational Chemistry
Chapter 9 - Subprograms (II): subroutines


9.1 Objectives

The main aims of this session consist of:

  1. considering the differences between functions and subroutines and in what cases are the latter useful.

  1. introducing the user to the subroutine definition procedures.

  1. explaining subroutine arguments roles.

  1. defining the commands CALL and INTERFACE.

  1. explaining the scope of the variables of a subroutine and the role of local variables and of variables with the SAVE attribute.

  1. presenting the different ways of passing an array as an argument to a subroutine.

  1. defining the so called automatic arrays.


9.2 Main items.

  1. The use of subroutines favors a structured programming through the definition of subtasks and avoiding code duplication. Together with functions, they make possible to access to an extense collection of libraries for multiple applications.

  1. To better explain this point we will make use of a simple example: solving a second order equation. A possible way of dividing this task in simpler subtasks is as follows

    1. Main program.

    1. Equation coefficient input.

    1. Solution of the algebraic equation.

    1. Solution output.

    The program excode_9_1.f90, Section 9.3.1 follows closely this scheme with two subroutines: Interact and Solve.

  1. The syntax to define a subroutine is as follows

           SUBROUTINE subroutine_name(arguments [optional])
                  IMPLICIT NONE
                  Arguments (dummy variables) definition (INTENT)
                  ...
                  Local variables definition
                  ...
                  Execution Section
                  ...
                  [RETURN]
          END SUBROUTINE  subroutine_name
    

    Argumentos are called dummy because their definition is not followed by a memory assignment, this assignment will take place once the subroutine is called.

    Each subroutine is compiled in a separate way by the compiler, what allows for the use of local variables that may have the same name in different subroutines and the main program without clashing due to the different scopes.

    This scheme can be seen in program excode_9_1.f90, Section 9.3.1.

  1. A subroutine is invoked with the CALL command as follows

         CALL subroutine_name(arguments [optional])
    

    Once the subroutine is executed the program flow returns to the program unit where the subroutine was invoked, after the CALL statement. The subroutine determines when to return to the invoking unit once the RETURN statement is found or if the subroutine execution ends.

  1. The subroutine and the main program data flow takes place through the arguments, also called subroutine parameters. Arguments in the subroutine definition are dummy variables, with an associated type but no space reserved in memory. For example, the E, F, and G arguments in the Solve subroutine in the code excode_9_1.f90, Section 9.3.1 are of REAL type, but without any memory allocation. Only when the subroutine is invoked with the CALL Solve(P,Q,R,Root1,Root2,IFail) command the arguments E, F, and G are replaced by pointers to the main program variables P, Q, and R. This is why it is of great importance that the data type of variables and arguments match correctly.

  1. Some of the arguments provide the necessary input for the subroutine, while others are output arguments that send the subroutine results to the invoking program unit. Mixed character input/output arguments can also be used.

    Those parameters that are only input parameters should be defined using the INTENT(IN) attribute that, as it is the case with functions, indicate that the argument values cannot be altered in the subroutine.

    If the parameters are output, the arguments should be defined with the INTENT(OUT) attribute, to avoid taking into account the input value of the argument.

    Mixed character arguments should be defined with the INTENT(INOUT) attribute.

    The subroutine Solve in example excode_9_1.f90, Section 9.3.1 provides examples for the three cases. It is advisable to label with the corresponding INTENT attribute every argument.

  1. In order to facilitate the accordance between variables in the invoking program unit and the subroutine the user can defined the so called interface blocks. The example excode_9_2.f90, Section 9.3.2 is the same code than excode_9_1.f90, Section 9.3.1 to which interface blocks have been added for the Interact and Solve subroutines.

  1. As in the case of functions, those variables defined in a subroutine that are not arguments are considered as local variables. For example, the Interact subroutine in excode_9_1.f90, Section 9.3.1 has a local variable called IO_Status.

    In general the local variables are created once the subroutine is called and the value is lost unless they possess the SAVE attribute, that makes possible to store the variable value from one call to the next. For example

         INTEGER, SAVE:: It = 0
    

    The variable It value is kept among different calls to the subroutine.

    As it is the case for functions, it is possible that the subprogram has access to the main program variables making use of the CONTAINS statement. This solution can be hard to scale once programs acquire certain size and it is not very advisable.

  1. When the argument of a subroutine is of array type it is necessary to provide some extra information about the matrix to avoid the possible access of the subroutine to wrong memory areas. In order to achieve this there are three possible ways of specifying the dimensiones of an array included in a subroutine list of arguments.

    1. explicit-shape approach:

      In this case the dimensions of the matrices are included as arguments in the subroutine call and the matrices are declared making use of these arguments. For example, if in a subroutine called test_pass an input vector (space_vec_in) and an output vector (space_vec_out) with equal dimensions are used, if we make use of the explicit-shape approach the subroutine starts as follows

           SUBROUTINE test_pass(space_vec_in, space_vec_out, dim_vec)
                    IMPLICIT NONE
                    INTEGER, INTENT(IN) :: dim_vec
                    REAL, INTENT(IN), DIMENSION(1:dim_vec) :: space_vec_in
                    REAL, INTENT(OUT), DIMENSION(1:dim_vec) :: space_vec_out
                    ......
            END SUBROUTINE test_pass
      
    1. assumed-shape approach:

      The main difference with the previous case is that either the corresponding INTERFACE block is added or, as explained in Subprograms (III): modules, Chapter 10, the subroutine is embedded in a module.

      The example code excode_9_3.f90, Section 9.3.3 calculates the mean, the median[11], the variance and the standard deviation of a set of random numbers following a continuous uniform distribution. Several points of interest has been marked in the program.

      • (1-3) Dynamic memory storage using the ALLOCATABLE attribute and the ALLOCATE statement. Notice that the array is a vector (DIMENSION(:)) and this piece of info needs to be also include in the interface block. The use of the interface block in cases like this one is mandatory. The statement (3), ALLOCATE(X(1:N), STAT = IERR) defines the length of the X vector. We also use the optional field STAT to check whether the array has been correctly dimensioned or not. Only if the output of this field, in the IERR variable, is zero the dynamic allocation has worked flawlessly.

               REAL , ALLOCATABLE , DIMENSION(:) :: X  !! (1)
             
               ...
             
               INTERFACE
                  SUBROUTINE STATS(X,N,MEAN,STD_DEV,MEDIAN)
                    IMPLICIT NONE
             
                    ...
             
                    REAL      , INTENT(IN) , DIMENSION(:)   ::    X  !!  (1)
             
                    ...
             
                  END SUBROUTINE STATS
               END INTERFACE
        

        It is important to take into account that an argument of a subroutine can have the ALLOCATABLE attribute, as well as local subroutine variables, but not dummy variables.

        The assumed shape arguments are nonexistent in FORTRAN 77, and it is the recommended form of transmitting arguments between a main program and a subprogram. In this form there is no transmitted information about the dimension of the array, and the argument and the main program variable need to have equal type, range, and class (KIND).

      • (4) and (6): these statements take advantage of the Fortran 90 rules to work with vector and arrays.

      • (5) In this statement the allocated memory is revoked and freed using the DEALLOCATE statement. This is not mandatory in programs like the present example, though it is necessary to do so when the allocatable array has been defined in a function of subroutine without the SAVE attribute.

      • (7) The CONTAINS statement is used to make the sorting subroutine SELECTION have access to the variables of the STATS subroutine. This is why in the SELECTION subroutine with the sorting algorithm only local variables need to be defined.

      The definition of INTERFACE blocks is a task simplified making use of modules, that are introduced in the next chapter.

    1. assumed-size approach

      This case is not advised due to the lack of info in the subroutine about the matrix dimensiones. This makes easy to make errors of difficult diagnose. Its use is not encouraged.

  1. Multidimensional arrays. The source code excode_9_5.f90, Section 9.3.5 is an example of how to pass multidimensional arrays as arguments of a subroutine as assumed shape arrays. The user defines two arrays , A and B, and the program computes the C array as the matrix product A times B. Then, the program computes the transpose matrix of A. The program makes use of the Fortran 90 functions MATMUL and TRANSPOSE.

  1. Subroutines can contain automatic arrays, that may depend on the subroutine argument values. These are local array that may not have the SAVE attribute. They are created when the subroutine is invoked and destroyed when the execution flow leaves the subroutine. It is preferable to use ALLOCATABLE arrays.

  1. An argument of CHARACTER type is also diffenrent in the sense that if such argument is declared with a length LEN = *, once the subroutine is called the variable length is the legth of the variable in the call.

    The code excode_9_4.f90, Section 9.3.4 is a program to which a file name is given and the number of data pairs stored in the file. The program opens the file and reads the two-column dataset. Notice that, due to the variable size of the CHARACTER variable, the interface block is required.

    The example excode_9_6.f90, Section 9.3.6 caluculate two pseudo random number vectors with a Gaussian or normal distribution with a dimension defined by the user. This is achieved with the Box-Mueller method.

    Two ALLOCATABLE arrays, X and Y are difined and in the internal subroutine BOX_MULLER two vectors of automatic type are defined: RANDOM_u and RANDOM_v.

    The mean value, the median and the standard deviation are computed making use of the STATS subroutine in the source code excode_9_3.f90, Section 9.3.3. The necessary INTERFACE block is included in the main program and the subroutine should be compiled in a separate file.

  1. It is important to take into account that when array arguments are used as assumed shape arguments the first index of the variable in the subroutine by default takes a value 1, unless it is explicitly indicated. The example excode_9_7.f90, Section 9.3.7 is a simple case where this initial value is indicated. This program cmputes the factorial of the integers in the range between IMIN and IMAX, storing them in a real vector. The program can be compiled making IMIN = 1 or IMIN = 0 with and without the definition of the initial index in the subroutine to check the different outputs.


9.3 Example Codes


9.3.1 excode_9_1.f90

     PROGRAM ex_9_1
       !
       IMPLICIT NONE
       ! Simple program with two subroutines.
       ! subroutine (1):: Interact :: Data input.
       ! subroutine (2):: Solve :: Solve second order Eq.
       !
       ! Variables
       REAL :: P, Q, R, Root1, Root2
       INTEGER :: IFail=0
       LOGICAL :: OK=.TRUE.
       !
       CALL Interact(P,Q,R,OK) ! Subrutina (1)
       !
       IF (OK) THEN
          !
          CALL Solve(P,Q,R,Root1,Root2,IFail) ! Subrutina (2)
          !
          IF (IFail == 1) THEN
             PRINT *,' Complex roots'
             PRINT *,' calculation aborted'
          ELSE
             PRINT *,' Roots are ',Root1,' ',Root2
          ENDIF
          !
       ELSE
          !
          PRINT*,' Error in data input program ends'
          !
       ENDIF
       !
     END PROGRAM ex_9_1
     !
     !
     SUBROUTINE Interact(A,B,C,OK)
       IMPLICIT NONE
       REAL , INTENT(OUT) :: A
       REAL , INTENT(OUT) :: B
       REAL , INTENT(OUT) :: C
       LOGICAL , INTENT(OUT) :: OK
       INTEGER :: IO_Status=0
       PRINT*,' Type in the coefficients A, B AND C'
       READ(UNIT=*,FMT=*,IOSTAT=IO_Status) A,B,C
       IF (IO_Status == 0) THEN
          OK=.TRUE.
       ELSE
          OK=.FALSE.
       ENDIF
     END SUBROUTINE Interact
     !
     !
     SUBROUTINE Solve(E,F,G,Root1,Root2,IFail)
       IMPLICIT NONE
       REAL , INTENT(IN) :: E
       REAL , INTENT(IN) :: F
       REAL , INTENT(IN) :: G
       REAL , INTENT(OUT) :: Root1
       REAL , INTENT(OUT) :: Root2
       INTEGER , INTENT(INOUT) :: IFail
       ! Local variables
       REAL :: Term
       REAL :: A2
       Term = F*F - 4.*E*G
       A2 = E*2.0
       ! if term < 0, roots are complex
       IF(Term < 0.0)THEN
          IFail=1
       ELSE
          Term = SQRT(Term)
          Root1 = (-F+Term)/A2
          Root2 = (-F-Term)/A2
       ENDIF
     END SUBROUTINE Solve

9.3.2 excode_9_2.f90

     PROGRAM ex_9_2
       !
       IMPLICIT NONE
       ! Simple program with two subroutines.
       ! subroutine (1):: Interact :: Data input.
       ! subroutine (2):: Solve :: Solve second order Eq.
       !
       ! Interface blocks
       INTERFACE
          SUBROUTINE Interact(A,B,C,OK)
            IMPLICIT NONE
            REAL , INTENT(OUT) ::  A
            REAL , INTENT(OUT) ::  B
            REAL , INTENT(OUT) ::  C
            LOGICAL , INTENT(OUT) :: OK
          END SUBROUTINE Interact
          SUBROUTINE Solve(E,F,G,Root1,Root2,IFail)
            IMPLICIT NONE
            REAL , INTENT(IN) :: E
            REAL , INTENT(IN) :: F
            REAL , INTENT(IN) :: G
            REAL , INTENT(OUT) :: Root1
            REAL , INTENT(OUT) :: Root2
            INTEGER , INTENT(INOUT) :: IFail
          END SUBROUTINE Solve
       END INTERFACE
       !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       !
       ! Variables
       REAL :: P, Q, R, Root1, Root2
       INTEGER :: IFail=0
       LOGICAL :: OK=.TRUE.
       !
       CALL Interact(P,Q,R,OK) ! Subrutina (1)
       !
       IF (OK) THEN
          !
          CALL Solve(P,Q,R,Root1,Root2,IFail) ! Subrutina (2)
          !
          IF (IFail == 1) THEN
             PRINT *,' Complex roots'
             PRINT *,' calculation aborted'
          ELSE
             PRINT *,' Roots are ',Root1,' ',Root2
          ENDIF
          !
       ELSE
          !
          PRINT*,' Error in data input program ends'
          !
       ENDIF
       !
     END PROGRAM ex_9_2
     !
     !
     SUBROUTINE Interact(A,B,C,OK)
       IMPLICIT NONE
       REAL , INTENT(OUT) :: A
       REAL , INTENT(OUT) :: B
       REAL , INTENT(OUT) :: C
       LOGICAL , INTENT(OUT) :: OK
       INTEGER :: IO_Status=0
       PRINT*,' Type in the coefficients A, B AND C'
       READ(UNIT=*,FMT=*,IOSTAT=IO_Status)A,B,C
       IF (IO_Status == 0) THEN
          OK=.TRUE.
       ELSE
          OK=.FALSE.
       ENDIF
     END SUBROUTINE Interact
     !
     !
     SUBROUTINE Solve(E,F,G,Root1,Root2,IFail)
       IMPLICIT NONE
       REAL , INTENT(IN) :: E
       REAL , INTENT(IN) :: F
       REAL , INTENT(IN) :: G
       REAL , INTENT(OUT) :: Root1
       REAL , INTENT(OUT) :: Root2
       INTEGER , INTENT(INOUT) :: IFail
       ! Local variables
       REAL :: Term
       REAL :: A2
       Term = F*F - 4.*E*G
       A2 = E*2.0
       ! if term < 0, roots are complex
       IF(Term < 0.0)THEN
          IFail=1
       ELSE
          Term = SQRT(Term)
          Root1 = (-F+Term)/A2
          Root2 = (-F-Term)/A2
       ENDIF
     END SUBROUTINE Solve

9.3.3 excode_9_3.f90

     PROGRAM ex_9_3
       !
       IMPLICIT NONE
       !
       ! Variables
       INTEGER :: N
       REAL , ALLOCATABLE , DIMENSION(:) :: X  !! (1)
       REAL :: M,SD,MEDIAN
       INTEGER :: IERR
       !
       ! interface block   !! (2)
       INTERFACE
          SUBROUTINE STATS(VECTOR,N,MEAN,STD_DEV,MEDIAN)
            IMPLICIT NONE
            INTEGER , INTENT(IN)                    ::  N
            REAL      , INTENT(IN) , DIMENSION(:)   :: VECTOR  !!  (1)
            REAL      , INTENT(OUT)                 :: MEAN
            REAL      , INTENT(OUT)                 :: STD_DEV
            REAL      , INTENT(OUT)                 :: MEDIAN
          END SUBROUTINE STATS
       END INTERFACE
       PRINT *,' Length of random values vector ?'
       READ *,N
       ALLOCATE(X(1:N), STAT = IERR)     !!  (3)
       IF (IERR /= 0) THEN
          PRINT*, "X allocation request denied."
          STOP
       ENDIF
       CALL RANDOM_NUMBER(X)
       X=X*1000             !!  (4)
       CALL STATS(X,N,M,SD,MEDIAN)
       !
       PRINT *,' MEAN = ',M
       PRINT *,' STANDARD DEVIATION = ',SD
       PRINT *,' MEDIAN IS = ',MEDIAN
       !
       IF (ALLOCATED(X)) DEALLOCATE(X, STAT = IERR)   !! (5)
       IF (IERR /= 0) THEN
          PRINT*, "X NON DEALLOCATED!"
          STOP
       ENDIF
     END PROGRAM ex_9_3
     !
     SUBROUTINE STATS(VECTOR,N,MEAN,STD_DEV,MEDIAN)
       IMPLICIT NONE
       ! Defincion de variables
       INTEGER , INTENT(IN)                    ::  N
       REAL      , INTENT(IN) , DIMENSION(:)    ::  VECTOR    !! (1)
       REAL      , INTENT(OUT)                  ::  MEAN
       REAL      , INTENT(OUT)                  ::  STD_DEV
       REAL      , INTENT(OUT)                  ::  MEDIAN
       REAL      , DIMENSION(1:N)              ::  Y
       REAL :: VARIANCE = 0.0
       REAL      :: SUMXI = 0.0, SUMXI2 = 0.0
       !
       SUMXI=SUM(VECTOR)       !! (6)
       SUMXI2=SUM(VECTOR*VECTOR)    !! (6)
       MEAN=SUMXI/N       
       VARIANCE=(SUMXI2-SUMXI*SUMXI/N)/(N-1)
       STD_DEV = SQRT(VARIANCE)
       Y=VECTOR
       ! Ordena valores por proceso de seleccion
       CALL SELECTION
       IF (MOD(N,2) == 0) THEN
          MEDIAN=(Y(N/2)+Y((N/2)+1))/2
       ELSE
          MEDIAN=Y((N/2)+1)
       ENDIF
     CONTAINS     !! (7)
       SUBROUTINE SELECTION
         IMPLICIT NONE
         INTEGER :: I,J,K
         REAL :: MINIMUM
         DO I=1,N-1
            K=I
            MINIMUM=Y(I)
            DO J=I+1,N
               IF (Y(J) < MINIMUM) THEN
                  K=J
                  MINIMUM=Y(K)
               END IF
            END DO
            Y(K)=Y(I)
            Y(I)=MINIMUM
         END DO
       END SUBROUTINE SELECTION
     END SUBROUTINE STATS

9.3.4 excode_9_4.f90

     PROGRAM ex_9_4
       IMPLICIT NONE
       REAL,DIMENSION(1:100)::A,B
       INTEGER :: Nos,I
       CHARACTER(LEN=32)::Filename
       INTERFACE
          SUBROUTINE Readin(Name,X,Y,N)
            IMPLICIT NONE
            INTEGER , INTENT(IN) :: N
            REAL,DIMENSION(1:N),INTENT(OUT)::X,Y
            CHARACTER (LEN=*),INTENT(IN)::Name
          END SUBROUTINE Readin
       END INTERFACE
       PRINT *,' Type in the name of the data file'
       READ '(A)' , Filename
       PRINT *,' Input the number of items in the file'
       READ * , Nos
       CALL Readin(Filename,A,B,Nos)
       PRINT * , ' Data read in was'
       DO I=1,Nos
          PRINT *,' ',A(I),' ',B(I)
       ENDDO
     END PROGRAM ex_9_4
     SUBROUTINE Readin(Name,X,Y,N)
       IMPLICIT NONE
       INTEGER , INTENT(IN) :: N
       REAL,DIMENSION(1:N),INTENT(OUT)::X,Y
       CHARACTER (LEN=*),INTENT(IN)::Name
       INTEGER::I
       OPEN(UNIT=10,STATUS='OLD',FILE=Name)
       DO I=1,N
          READ(10,*)X(I),Y(I)
       END DO
       CLOSE(UNIT=10)
     END SUBROUTINE Readin

9.3.5 excode_9_5.f90

     PROGRAM ex_9_5
       IMPLICIT NONE
       REAL , ALLOCATABLE , DIMENSION &
            (:,:)::One,Two,Three,One_T
       INTEGER :: I,N
       INTERFACE
          SUBROUTINE Matrix_bits(A,B,C,A_T)
            IMPLICIT NONE
            REAL, DIMENSION (:,:), INTENT(IN) :: A,B
            REAL, DIMENSION (:,:), INTENT(OUT) :: C,A_T
          END SUBROUTINE Matrix_bits
       END INTERFACE
       PRINT *,'Matrix Dimension?'
       READ*,N
       ALLOCATE(One(1:N,1:N))
       ALLOCATE(Two(1:N,1:N))
       ALLOCATE(Three(1:N,1:N))
       ALLOCATE(One_T(1:N,1:N))
       DO I=1,N
          PRINT*, 'Row ', I,'-th of the first array?'
          READ*,One(I,1:N)
       END DO
       DO I=1,N
          PRINT*, 'Row ', I,'-th of the second array?'
          READ*,Two(I,1:N)
       END DO
       CALL Matrix_bits(One,Two,Three,One_T)
       PRINT*,' Result: Matrix Product'
       DO I=1,N
          PRINT *,Three(I,1:N)
       END DO
       PRINT *,' Transpose A^T:'
       DO I=1,N
          PRINT *,One_T(I,1:N)
       END DO
     END PROGRAM ex_9_5
     !
     SUBROUTINE Matrix_bits(A,B,C,A_T)
       IMPLICIT NONE
       REAL, DIMENSION (:,:), INTENT(IN) :: A,B
       REAL, DIMENSION (:,:), INTENT(OUT) :: C,A_T
       C=MATMUL(A,B)
       A_T=TRANSPOSE(A)
     END SUBROUTINE Matrix_bits

9.3.6 excode_9_6.f90

     PROGRAM ex_9_6
       !
       IMPLICIT NONE
       !
       INTEGER :: I, IERR
       REAL, DIMENSION(:), ALLOCATABLE :: X, Y
       REAL :: M, SD, MEDIAN
       ! interface block   
       INTERFACE
          SUBROUTINE STATS(VECTOR,N,MEAN,STD_DEV,MEDIAN)
            IMPLICIT NONE
            INTEGER , INTENT(IN)                    ::  N
            REAL      , INTENT(IN) , DIMENSION(:)   :: VECTOR  
            REAL      , INTENT(OUT)                 :: MEAN
            REAL      , INTENT(OUT)                 :: STD_DEV
            REAL      , INTENT(OUT)                 :: MEDIAN
          END SUBROUTINE STATS
       END INTERFACE
       !
       READ*, I  
       !
       ALLOCATE(X(1:I), STAT = IERR)    
       IF (IERR /= 0) THEN
          PRINT*, "X allocation request denied."
          STOP
       ENDIF
       !
       ALLOCATE(Y(1:I), STAT = IERR)    
       IF (IERR /= 0) THEN
          PRINT*, "Y allocation request denied."
          STOP
       ENDIF
       !
       CALL BOX_MULLER(I)
       !
       PRINT*, X
       CALL STATS(X,I,M,SD,MEDIAN)
       !
       PRINT *,' MEAN = ',M
       PRINT *,' STANDARD DEVIATION = ',SD
       PRINT *,' MEDIAN IS = ',MEDIAN
       !
       IF (ALLOCATED(X)) DEALLOCATE(X, STAT = IERR) 
       IF (IERR /= 0) THEN
          PRINT*, "X NON DEALLOCATED!"
          STOP
       ENDIF
       PRINT*, Y
       CALL STATS(Y,I,M,SD,MEDIAN)
       !
       PRINT *,' MEAN = ',M
       PRINT *,' STANDARD DEVIATION = ',SD
       PRINT *,' MEDIAN IS = ',MEDIAN
       !
       IF (ALLOCATED(Y)) DEALLOCATE(Y, STAT = IERR)   
       IF (IERR /= 0) THEN
          PRINT*, "Y NON DEALLOCATED!"
          STOP
       ENDIF
       !
     CONTAINS
       !
       SUBROUTINE BOX_MULLER(dim)
         ! 
         ! Uses the Box-Muller method to create two normally distributed vectors
         !
         INTEGER, INTENT(IN) :: dim
         !
         REAL, PARAMETER :: PI = ACOS(-1.0)
         REAL, DIMENSION(dim) :: RANDOM_u, RANDOM_v ! Automatic arrays
         !
         CALL RANDOM_NUMBER(RANDOM_u)
         CALL RANDOM_NUMBER(RANDOM_v)
         !
         X = SQRT(-2.0*LOG(RANDOM_u))
         Y = X*SIN(2*PI*RANDOM_v)
         X = X*COS(2*PI*RANDOM_v)
         !
       END SUBROUTINE BOX_MULLER
       !
     END PROGRAM ex_9_6
     !!!!!!!!!!!!!!!!!!!!!!!!!
     !!!!!!!!!!!!!!!!!!!!!!!!!
     SUBROUTINE STATS(VECTOR,N,MEAN,STD_DEV,MEDIAN)
       IMPLICIT NONE
       ! Arguments
       INTEGER , INTENT(IN)                    ::  N
       REAL      , INTENT(IN) , DIMENSION(:)    ::  VECTOR    !! (1)
       REAL      , INTENT(OUT)                  ::  MEAN
       REAL      , INTENT(OUT)                  ::  STD_DEV
       REAL      , INTENT(OUT)                  ::  MEDIAN
       ! Local Variables
       REAL      , DIMENSION(1:N)              ::  Y
       REAL      :: VARIANCE = 0.0
       REAL      :: SUMXI = 0.0, SUMXI2 = 0.0
       !
       SUMXI=SUM(VECTOR)       !! (6)
       SUMXI2=SUM(VECTOR*VECTOR)    !! (6)
       MEAN=SUMXI/N       
       VARIANCE=(SUMXI2-SUMXI*SUMXI/N)/(N-1)
       STD_DEV = SQRT(VARIANCE)
       Y=VECTOR
       ! Sort values
       CALL SELECTION
       IF (MOD(N,2) == 0) THEN
          MEDIAN=(Y(N/2)+Y((N/2)+1))/2
       ELSE
          MEDIAN=Y((N/2)+1)
       ENDIF
     CONTAINS     !! (7)
       SUBROUTINE SELECTION
         IMPLICIT NONE
         INTEGER :: I,J,K
         REAL :: MINIMUM
         DO I=1,N-1
            K=I
            MINIMUM=Y(I)
            DO J=I+1,N
               IF (Y(J) < MINIMUM) THEN
                  K=J
                  MINIMUM=Y(K)
               END IF
            END DO
            Y(K)=Y(I)
            Y(I)=MINIMUM
         END DO
       END SUBROUTINE SELECTION
     END SUBROUTINE STATS

9.3.7 excode_9_7.f90

     PROGRAM ex_9_7
       !
       IMPLICIT NONE
       !
       INTERFACE
          SUBROUTINE SUBEXAMPLE(IMIN, IMAX, FACT_MAT)
            INTEGER, intent(in) :: IMIN, IMAX
            REAL, DIMENSION(IMIN:), intent(out) :: FACT_MAT
          END SUBROUTINE SUBEXAMPLE
       END INTERFACE
       !
       ! Variables
       REAL, DIMENSION(:), ALLOCATABLE :: FACT_MAT
       INTEGER :: IMIN, IMAX, I
       !
       IMIN = 0
       IMAX = 5
       !
       ALLOCATE(FACT_MAT(IMIN:IMAX))
       !
       PRINT*, "MAIN", SIZE(FACT_MAT)
       !
       CALL SUBEXAMPLE(IMIN, IMAX, FACT_MAT)
       !
       DO I = IMIN, IMAX
          PRINT*, I, FACT_MAT(I)
       ENDDO
       !
     END PROGRAM ex_9_7
     !!!!!!!!!!
     !!!!!!!!!!
     SUBROUTINE SUBEXAMPLE(IMIN, IMAX, FACT_MAT)
       !
       IMPLICIT NONE
       INTEGER, intent(in) :: IMIN, IMAX
       REAL, DIMENSION(IMIN:), intent(out) :: FACT_MAT
       ! The subroutine with the next line only would work for IMIN = 1
       !  REAL, DIMENSION(:), intent(out) :: FACT_MAT
       !
       INTEGER :: j,k
       !
       PRINT*, "SUB", SIZE(FACT_MAT)
       !
       DO j = imin, imax
          fact_mat(j) = 1.0
          do k = 2, j
             fact_mat(j) = k*fact_mat(j)
          enddo
       ENDDO
       !
       !
     END SUBROUTINE SUBEXAMPLE

[ previous ] [ Contents ] [ 1 ] [ 2 ] [ 3 ] [ 4 ] [ 5 ] [ 6 ] [ 7 ] [ 8 ] [ 9 ] [ 10 ] [ 11 ] [ 12 ] [ 13 ] [ next ]


Fortran 90 Lessons for Computational Chemistry

0.0

Curro Pérez-Bernal mailto:francisco.perez@dfaie.uhu.es