tests/ctags/stdcall.f

   1 * Obtained from http://www.nag.com/local/nagping/np006a3.asp
   2 *     D02CJF Example Program Text
   3 *     Mark 14 Revised.  NAG Copyright 1989.
   4 *     .. Parameters ..
   5       CHARACTER        RELABS*15                                        !NEW
   6       INTEGER          NOUT
   7       PARAMETER        (NOUT=6)
   8       INTEGER          N, IW
   9       PARAMETER        (N=3,IW=21*N+28)
  10 *     .. Scalars in Common ..
  11       DOUBLE PRECISION H, XEND
  12       INTEGER          K
  13 *     .. Local Scalars ..
  14       DOUBLE PRECISION PI, TOL, X
  15       INTEGER          I, IFAIL, J
  16 *     .. Local Arrays ..
  17       DOUBLE PRECISION W(IW), Y(N)
  18 *     .. External Functions ..
  19       DOUBLE PRECISION D02CJW, G, X01AAF
  20       STDCALL EXTERNAL D02CJW, G, X01AAF                                !CHANGE
  21 *     .. External Subroutines ..
  22       STDCALL EXTERNAL D02CJF, D02CJX, FCN, OUT                         !CHANGE
  23 *     .. Intrinsic Functions ..
  24       INTRINSIC        DBLE
  25 *     .. Common blocks ..
  26       COMMON           XEND, H, K
  27 *     .. Executable Statements ..
  28       WRITE (NOUT,*) 'D02CJF Example Program Results'
  29       RELABS = "Default"                                                !NEW
  30       XEND = 10.0D0
  31       PI = X01AAF(0.0D0)
  32       WRITE (NOUT,*)
  33       WRITE (NOUT,*) 'Case 1: intermediate output, root-finding'
  34       DO 20 J = 4, 5
  35          TOL = 10.0D0**(-J)
  36          WRITE (NOUT,*)
  37          WRITE (NOUT,99999) ' Calculation with TOL =', TOL
  38          X = 0.0D0
  39          Y(1) = 0.5D0
  40          Y(2) = 0.5D0
  41          Y(3) = PI/5.0D0
  42          K = 4
  43          H = (XEND-X)/DBLE(K+1)
  44          WRITE (NOUT,*) '     X         Y(1)         Y(2)         Y(3)'
  45          IFAIL = 0
  46 *
  47          CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),OUT,G,W,!CHANGE
  48      +               IFAIL)
  49 *
  50          WRITE (NOUT,99998) '  Root of Y(1) = 0.0 at', X
  51          WRITE (NOUT,99997) '  Solution is', (Y(I),I=1,N)
  52    20 CONTINUE
  53       WRITE (NOUT,*)
  54       WRITE (NOUT,*)
  55       WRITE (NOUT,*) 'Case 2: no intermediate output, root-finding'
  56       DO 40 J = 4, 5
  57          TOL = 10.0D0**(-J)
  58          WRITE (NOUT,*)
  59          WRITE (NOUT,99999) ' Calculation with TOL =', TOL
  60          X = 0.0D0
  61          Y(1) = 0.5D0
  62          Y(2) = 0.5D0
  63          Y(3) = PI/5.0D0
  64          IFAIL = 0
  65 *
  66          CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),D02CJX, !CHANGE
  67      +               G,W,IFAIL)
  68 *
  69          WRITE (NOUT,99998) '  Root of Y(1) = 0.0 at', X
  70          WRITE (NOUT,99997) '  Solution is', (Y(I),I=1,N)
  71    40 CONTINUE
  72       WRITE (NOUT,*)
  73       WRITE (NOUT,*)
  74       WRITE (NOUT,*) 'Case 3: intermediate output, no root-finding'
  75       DO 60 J = 4, 5
  76          TOL = 10.0D0**(-J)
  77          WRITE (NOUT,*)
  78          WRITE (NOUT,99999) ' Calculation with TOL =', TOL
  79          X = 0.0D0
  80          Y(1) = 0.5D0
  81          Y(2) = 0.5D0
  82          Y(3) = PI/5.0D0
  83          K = 4
  84          H = (XEND-X)/DBLE(K+1)
  85          WRITE (NOUT,*) '     X         Y(1)         Y(2)         Y(3)'
  86          IFAIL = 0
  87 *
  88          CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),OUT,    CHANGE
  89      +               D02CJW,W,IFAIL)
  90 *
  91    60 CONTINUE
  92       WRITE (NOUT,*)
  93       WRITE (NOUT,*)
  94       WRITE (NOUT,*)
  95      +'Case 4: no intermediate output, no root-finding ( integrate to XE
  96      +ND)'
  97       DO 80 J = 4, 5
  98          TOL = 10.0D0**(-J)
  99          WRITE (NOUT,*)
 100          WRITE (NOUT,99999) ' Calculation with TOL =', TOL
 101          X = 0.0D0
 102          Y(1) = 0.5D0
 103          Y(2) = 0.5D0
 104          Y(3) = PI/5.0D0
 105          WRITE (NOUT,*) '     X         Y(1)         Y(2)         Y(3)'
 106          WRITE (NOUT,99996) X, (Y(I),I=1,N)
 107          IFAIL = 0
 108 *
 109          CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),D02CJX, !CHANGE
 110      +               D02CJW,W,IFAIL)
 111 *
 112          WRITE (NOUT,99996) X, (Y(I),I=1,N)
 113    80 CONTINUE
 114       STOP
 115 *
 116 99999 FORMAT (1X,A,D8.1)
 117 99998 FORMAT (1X,A,F7.3)
 118 99997 FORMAT (1X,A,3F13.5)
 119 99996 FORMAT (1X,F8.2,3F13.5)
 120       END
 121 *
 122       STDCALL SUBROUTINE OUT(X,Y)                                       !CHANGE
 123 *     .. Parameters ..
 124       INTEGER        NOUT
 125       PARAMETER      (NOUT=6)
 126       INTEGER        N
 127       PARAMETER      (N=3)
 128 *     .. Scalar Arguments ..
 129       DOUBLE PRECISION X
 130 *     .. Array Arguments ..
 131       DOUBLE PRECISION Y(N)
 132 *     .. Scalars in Common ..
 133       DOUBLE PRECISION H, XEND
 134       INTEGER        I
 135 *     .. Local Scalars ..
 136       INTEGER        J
 137 *     .. Intrinsic Functions ..
 138       INTRINSIC      DBLE
 139 *     .. Common blocks ..
 140       COMMON         XEND, H, I
 141 *     .. Executable Statements ..
 142       WRITE (NOUT,99999) X, (Y(J),J=1,N)
 143       X = XEND - DBLE(I)*H
 144       I = I - 1
 145       RETURN
 146 *
 147 99999 FORMAT (1X,F8.2,3F13.5)
 148       END
 149 *
 150       STDCALL SUBROUTINE FCN(T,Y,F)                                     !CHANGE
 151 *     .. Parameters ..
 152       INTEGER        N
 153       PARAMETER      (N=3)
 154 *     .. Scalar Arguments ..
 155       DOUBLE PRECISION T
 156 *     .. Array Arguments ..
 157       DOUBLE PRECISION F(N), Y(N)
 158 *     .. Intrinsic Functions ..
 159       INTRINSIC      COS, TAN
 160 *     .. Executable Statements ..
 161       F(1) = TAN(Y(3))
 162       F(2) = -0.032D0*TAN(Y(3))/Y(2) - 0.02D0*Y(2)/COS(Y(3))
 163       F(3) = -0.032D0/Y(2)**2
 164       RETURN
 165       END
 166 *
 167       STDCALL DOUBLE PRECISION FUNCTION G(T,Y)                          !CHANGE
 168 *     .. Parameters ..
 169       INTEGER                     N
 170       PARAMETER                   (N=3)
 171 *     .. Scalar Arguments ..
 172       DOUBLE PRECISION            T
 173 *     .. Array Arguments ..
 174       DOUBLE PRECISION            Y(N)
 175 *     .. Executable Statements ..
 176       G = Y(1)
 177       RETURN
 178       END