"Fossies" - the Fresh Open Source Software Archive

Member "netcdf-fortran-4.5.2/nf_test/f03lib_f_interfaces.f90" (18 Sep 2019, 8561 Bytes) of package /linux/misc/netcdf-fortran-4.5.2.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Fortran 90 source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file.

    1 ! FORTRAN interfaces to the C utilties defined in fortlib.c
    2 !
    3 ! Written by: Richard Weed, Ph.D
    4 !             Center for Advanced Vehicular Systems
    5 !             Mississippi State University
    6 !             rweed@cavs.msstate.edu
    7 
    8 
    9 
   10 
   11 ! License (and other Lawyer Language)
   12  
   13 ! This software is released under the Apache 2.0 Open Source License. The
   14 ! full text of the License can be viewed at :
   15 !
   16 !   http:www.apache.org/licenses/LICENSE-2.0.html
   17 !
   18 ! The author grants to the University Corporation for Atmospheric Research
   19 ! (UCAR), Boulder, CO, USA the right to revise and extend the software
   20 ! without restriction. However, the author retains all copyrights and
   21 ! intellectual property rights explicitly stated in or implied by the
   22 ! Apache license
   23 
   24 ! Version 1.  June 2006
   25 !             Unchanged for netCDF 4.1.1
   26 
   27 !-------------------------------  udexit --------------------------------------
   28  Subroutine udexit(status)
   29 !
   30  USE ISO_C_BINDING, ONLY: C_INT
   31  Implicit NONE
   32 
   33  
   34  Integer, Intent(IN) :: status
   35  Integer(KIND=C_INT) :: cstatus
   36  Interface
   37   Subroutine exit(status) BIND(C)
   38   USE ISO_C_BINDING, ONLY: C_INT
   39   Integer(KIND=C_INT), VALUE :: status  
   40   End Subroutine exit
   41  End Interface
   42 
   43  cstatus = status
   44  Call exit(cstatus)
   45 
   46  End Subroutine udexit
   47 !-------------------------------  udabort --------------------------------------
   48  Subroutine udabort()
   49  USE ISO_C_BINDING
   50  Implicit NONE
   51  Interface
   52   Subroutine abort() BIND(C)
   53   End Subroutine abort
   54  End Interface
   55 
   56  Call abort()
   57 
   58  End Subroutine udabort
   59 !-------------------------------  udrand -------------------------------------
   60  Function udrand(iflag) RESULT(rannum)
   61 
   62  USE ISO_C_BINDING
   63 
   64  Implicit NONE
   65  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
   66  Integer, Intent(IN) :: iflag
   67  Real(RK8) :: rannum
   68  Integer(KIND=C_INT) :: ciflag
   69  Real(KIND=C_DOUBLE) :: crannum
   70  Interface
   71   Function myrand(iflag) BIND(C)
   72    USE ISO_C_BINDING, ONLY: C_INT, C_DOUBLE
   73    Integer(KIND=C_INT), VALUE :: iflag
   74    Real(KIND=C_DOUBLE) :: myrand
   75   End Function myrand
   76  End Interface
   77 
   78  ciflag = iflag
   79   
   80  crannum = myrand(ciflag)
   81  rannum = crannum
   82 
   83  End Function udrand
   84 !-------------------------------  udshift -------------------------------------
   85  Function udshift(ivalue, amount) RESULT(shiftval)
   86 
   87  USE ISO_C_BINDING
   88 
   89  Implicit NONE
   90 
   91  Integer, Intent(IN) :: ivalue, amount
   92  Integer(KIND=C_INT) :: cvalue, camount 
   93  Integer :: shiftval 
   94  Integer(KIND=C_INT) :: cshiftval
   95  Interface
   96   Function myshift(cvalue, camount) BIND(C)
   97    USE ISO_C_BINDING, ONLY: C_INT
   98    Integer(KIND=C_INT), VALUE :: cvalue, camount 
   99    Integer(KIND=C_INT) :: myshift
  100   End Function myshift
  101  End Interface
  102 
  103  cvalue = ivalue
  104  camount = amount
  105   
  106  cshiftval = myshift(cvalue, camount)
  107  shiftval = cshiftval
  108 
  109  End Function udshift
  110 !-------------------------------  ignorefpe  ----------------------------------
  111  Subroutine ignorefpe(idoit)
  112 
  113  USE ISO_C_BINDING
  114 
  115  Implicit NONE
  116 
  117  Integer, Intent(IN) :: idoit 
  118  Integer(KIND=C_INT) :: cdoit 
  119  Interface
  120   Subroutine nc_ignorefpe(cdoit) BIND(C)
  121    USE ISO_C_BINDING, ONLY: C_INT
  122    Integer(KIND=C_INT), VALUE :: cdoit 
  123   End Subroutine nc_ignorefpe 
  124  End Interface
  125 
  126  cdoit = idoit
  127  Call nc_ignorefpe(cdoit)
  128 
  129  End Subroutine ignorefpe
  130 !-------------------------------  max_uchar  ----------------------------------
  131  Function max_uchar() RESULT(cmax)
  132 
  133  USE ISO_C_BINDING
  134 
  135  Implicit NONE
  136  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  137  Real(RK8) :: cmax
  138  Real(KIND=C_DOUBLE) :: ccmax
  139  Interface
  140   Function cmax_uchar() BIND(C)
  141    USE ISO_C_BINDING, ONLY: C_DOUBLE
  142    Real(KIND=C_DOUBLE) :: cmax_uchar
  143   End Function cmax_uchar
  144  End Interface
  145 
  146  ccmax = cmax_uchar()
  147  cmax = ccmax
  148 
  149  End Function max_uchar
  150 !-------------------------------  min_schar  ----------------------------------
  151  Function min_schar() RESULT(cmin)
  152 
  153  USE ISO_C_BINDING
  154 
  155  Implicit NONE
  156  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  157  Real(RK8) :: cmin
  158  Real(KIND=C_DOUBLE) :: ccmin
  159  Interface
  160   Function cmin_schar() BIND(C)
  161    USE ISO_C_BINDING, ONLY: C_DOUBLE
  162    Real(KIND=C_DOUBLE) :: cmin_schar
  163   End Function cmin_schar
  164  End Interface
  165 
  166  ccmin = cmin_schar()
  167  cmin = ccmin
  168 
  169  End Function min_schar
  170 !-------------------------------  max_schar  ----------------------------------
  171  Function max_schar() RESULT(cmax)
  172 
  173  USE ISO_C_BINDING
  174 
  175  Implicit NONE
  176  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  177  Real(RK8) :: cmax
  178  Real(KIND=C_DOUBLE) :: ccmax
  179  Interface
  180   Function cmax_schar() BIND(C)
  181    USE ISO_C_BINDING, ONLY: C_DOUBLE
  182    Real(KIND=C_DOUBLE) :: cmax_schar
  183   End Function cmax_schar
  184  End Interface
  185 
  186  ccmax = cmax_schar()
  187  cmax = ccmax
  188 
  189  End Function max_schar
  190 !-------------------------------  min_short  ----------------------------------
  191  Function min_short() RESULT(cmin)
  192 
  193  USE ISO_C_BINDING
  194 
  195  Implicit NONE
  196  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  197  Real(RK8) :: cmin
  198  Real(KIND=C_DOUBLE) :: ccmin
  199  Interface
  200   Function cmin_short() BIND(C)
  201    USE ISO_C_BINDING, ONLY: C_DOUBLE
  202    Real(KIND=C_DOUBLE) :: cmin_short
  203   End Function cmin_short
  204  End Interface
  205 
  206  ccmin = cmin_short()
  207  cmin = ccmin
  208 
  209  End Function min_short
  210 !-------------------------------  max_short  ----------------------------------
  211  Function max_short() RESULT(cmax)
  212 
  213  USE ISO_C_BINDING
  214 
  215  Implicit NONE
  216  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  217  Real(RK8) :: cmax
  218  Real(KIND=C_DOUBLE) :: ccmax
  219  Interface
  220   Function cmax_short() BIND(C)
  221    USE ISO_C_BINDING, ONLY: C_DOUBLE
  222    Real(KIND=C_DOUBLE) :: cmax_short
  223   End Function cmax_short
  224  End Interface
  225 
  226  ccmax = cmax_short()
  227  cmax = ccmax
  228 
  229  End Function max_short
  230 !-------------------------------  min_int  ----------------------------------
  231  Function min_int() RESULT(cmin)
  232 
  233  USE ISO_C_BINDING
  234 
  235  Implicit NONE
  236  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  237  Real(RK8) :: cmin
  238  Real(KIND=C_DOUBLE) :: ccmin
  239  Interface
  240   Function cmin_int() BIND(C)
  241    USE ISO_C_BINDING, ONLY: C_DOUBLE
  242    Real(KIND=C_DOUBLE) :: cmin_int
  243   End Function cmin_int
  244  End Interface
  245 
  246  ccmin = cmin_int()
  247  cmin = ccmin
  248 
  249  End Function min_int
  250 !-------------------------------  max_int  ----------------------------------
  251  Function max_int() RESULT(cmax)
  252 
  253  USE ISO_C_BINDING
  254 
  255  Implicit NONE
  256  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  257  Real(RK8) :: cmax
  258  Real(KIND=C_DOUBLE) :: ccmax
  259  Interface
  260   Function cmax_int() BIND(C)
  261    USE ISO_C_BINDING, ONLY: C_DOUBLE
  262    Real(KIND=C_DOUBLE) :: cmax_int
  263   End Function cmax_int
  264  End Interface
  265 
  266  ccmax = cmax_int()
  267  cmax = ccmax
  268 
  269  End Function max_int
  270 !-------------------------------  min_long  ----------------------------------
  271  Function min_long() RESULT(cmin)
  272 
  273  USE ISO_C_BINDING
  274 
  275  Implicit NONE
  276  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  277  Real(RK8) :: cmin
  278  Real(KIND=C_DOUBLE) :: ccmin
  279  Interface
  280   Function cmin_long() BIND(C)
  281    USE ISO_C_BINDING, ONLY: C_DOUBLE
  282    Real(KIND=C_DOUBLE) :: cmin_long
  283   End Function cmin_long
  284  End Interface
  285 
  286  ccmin = cmin_long()
  287  cmin = ccmin
  288 
  289  End Function min_long
  290 !-------------------------------  max_long  ----------------------------------
  291  Function max_long() RESULT(cmax)
  292 
  293  USE ISO_C_BINDING
  294 
  295  Implicit NONE
  296  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  297  Real(RK8) :: cmax
  298  Real(KIND=C_DOUBLE) :: ccmax
  299  Interface
  300   Function cmax_long() BIND(C)
  301    USE ISO_C_BINDING, ONLY: C_DOUBLE
  302    Real(KIND=C_DOUBLE) :: cmax_long
  303   End Function cmax_long
  304  End Interface
  305 
  306  ccmax = cmax_long()
  307  cmax = ccmax
  308 
  309  End Function max_long
  310 !-------------------------------  max_float  ----------------------------------
  311  Function max_float() RESULT(cmax)
  312 
  313  USE ISO_C_BINDING
  314 
  315  Implicit NONE
  316  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  317  Real(RK8) :: cmax
  318  Real(KIND=C_DOUBLE) :: ccmax
  319  Interface
  320   Function cmax_float() BIND(C)
  321    USE ISO_C_BINDING, ONLY: C_DOUBLE
  322    Real(KIND=C_DOUBLE) :: cmax_float
  323   End Function cmax_float
  324  End Interface
  325 
  326  ccmax = cmax_float()
  327  cmax = ccmax
  328 
  329  End Function max_float
  330 !-------------------------------  max_double  ----------------------------------
  331  Function max_double() RESULT(cmax)
  332 
  333  USE ISO_C_BINDING
  334 
  335  Implicit NONE
  336  Integer, Parameter :: RK8=SELECTED_REAL_KIND(P=13, R=307)  ! double
  337  Real(RK8) :: cmax
  338  Real(KIND=C_DOUBLE) :: ccmax
  339  Interface
  340   Function cmax_double() BIND(C)
  341    USE ISO_C_BINDING, ONLY: C_DOUBLE
  342    Real(KIND=C_DOUBLE) :: cmax_double
  343   End Function cmax_double
  344  End Interface
  345 
  346  ccmax = cmax_double()
  347  cmax = ccmax
  348 
  349  End Function max_double