1!-----------------------------------------------------------------------------
2!
3!  Copyright (C) 1997-2013 Krzysztof M. Gorski, Eric Hivon,
4!                          Benjamin D. Wandelt, Anthony J. Banday,
5!                          Matthias Bartelmann, Hans K. Eriksen,
6!                          Frode K. Hansen, Martin Reinecke
7!
8!
9!  This file is part of HEALPix.
10!
11!  HEALPix is free software; you can redistribute it and/or modify
12!  it under the terms of the GNU General Public License as published by
13!  the Free Software Foundation; either version 2 of the License, or
14!  (at your option) any later version.
15!
16!  HEALPix is distributed in the hope that it will be useful,
17!  but WITHOUT ANY WARRANTY; without even the implied warranty of
18!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19!  GNU General Public License for more details.
20!
21!  You should have received a copy of the GNU General Public License
22!  along with HEALPix; if not, write to the Free Software
23!  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
24!
25!  For more information about HEALPix see http://healpix.sourceforge.net
26!
27!-----------------------------------------------------------------------------
28module extension
29  !
30  ! defines in F90 some C commands
31  ! These extensions are not completely standard in all F90/95 compilers
32  !
33  ! getEnvironment   : emulates getenv
34  ! getArgument      : emulates getarg
35  ! nArguments       : emulates iargc
36  !
37  ! written by Eric Hivon, Nov 2001
38  !
39  ! exit_with_status : verbose and clean exit, added by M.R.
40  ! 2005-08: edited for Gfortran
41  ! 2013-05-07: G95-compatible
42  ! 2015-07-31: G95-compatible
43  ! 2016-05: edited for __GFORTRAN__
44
45#ifdef NAG
46  USE f90_unix, ONLY : iargc, getarg, exit
47#endif
48!VF  USE dflib, ONLY : nargs, getarg
49
50  USE healpix_types, ONLY : I4B, I8B
51  IMPLICIT none
52
53#if ((!defined(NAG)) && (!defined(GFORTRAN)) && (!defined(__GFORTRAN__)))
54interface
55  function iargc()
56    integer iargc
57  end function
58
59  subroutine getarg (num, res)
60    integer, intent(in) :: num
61    character(len=*), intent(out) :: res
62  end subroutine
63end interface
64#endif
65
66! work-around G95 bug (2013-05-07)
67  integer(kind=I4B), parameter, private :: arg_shift = 0
68!  integer(kind=I4B), private :: arg_shift = 0
69!VF  integer(kind=I4B), private :: arg_shift = 1
70
71#ifdef NO64BITS
72  interface exit_with_status
73     module procedure exit_with_status
74  end interface
75#else
76  interface exit_with_status
77     module procedure exit_with_status, exit_with_status_8
78  end interface
79#endif
80  private
81  public :: getEnvironment, getArgument, nArguments, exit_with_status
82
83  contains
84
85#if (defined (GFORTRAN) || defined(__GFORTRAN__) )
86
87    ! ===========================================================
88    function iargc ()
89    ! ===========================================================
90       integer iargc
91       ! ===========================================================
92
93       iargc=command_argument_count()
94    end function
95
96    ! ===========================================================
97    subroutine getarg(num, res)
98    ! ===========================================================
99       !integer, intent(in) :: num ! G95, 2015-07-30
100       integer(i4b), intent(in) :: num
101       character(len=*), intent(out) :: res
102       integer num1, l, err
103       ! ===========================================================
104       num1 = num
105       call get_command_argument(num1,res,l,err)
106    end subroutine
107
108#endif
109
110    ! ===========================================================
111    function nArguments() result(narg)
112      ! ===========================================================
113      integer(kind=I4B) :: narg
114      ! ===========================================================
115
116      narg = iargc() - arg_shift
117!VF      narg = nargs() - arg_shift
118
119      return
120    end function nArguments
121    ! ===========================================================
122    subroutine getEnvironment(name, value)
123      ! ===========================================================
124      character(len=*), intent(in) :: name
125      character(len=*), intent(out) :: value
126      integer(kind=I4B) :: inull, lnstr
127!       character(len=200) :: name1
128      ! ===========================================================
129      ! call C routine after adding a trailing NULL to input
130      value = ""
131      call cgetenvironment(trim(adjustl(name))//char(0), value)
132      ! remove trailing NULL (\0) created by C routine on output
133      lnstr = len(value)
134      inull = index(value, char(0), back=.true.)
135      if (inull > 0 .and. inull < lnstr) value(inull:inull) = " "
136
137      return
138    end subroutine getEnvironment
139    ! ===========================================================
140    subroutine getArgument(index, argument)
141      ! ===========================================================
142      integer(kind=I4B), intent(in) :: index
143      character(len=*), intent(out) :: argument
144      integer(kind=I4B) :: i1
145      ! ===========================================================
146      i1 = index + arg_shift
147      call getarg(i1, argument)
148
149      return
150    end subroutine getArgument
151
152
153
154! i4b and i8b versions of exit_with_status   ! G95 2015-07-30
155    ! ===========================================================
156    subroutine exit_with_status (code, msg)
157      ! ===========================================================
158      integer(i4b), intent(in) :: code
159      character (len=*), intent(in), optional :: msg
160      ! ===========================================================
161      if (present(msg)) print *,trim(msg)
162      print *,'program exits with exit code ', code
163#if (defined (RS6000))
164      call exit_ (code)
165#else
166      call exit (code)
167#endif
168    end subroutine exit_with_status
169
170#ifndef NO64BITS
171    ! ===========================================================
172    subroutine exit_with_status_8 (code, msg)
173      ! ===========================================================
174      integer(i8b), intent(in) :: code
175      character (len=*), intent(in), optional :: msg
176      ! ===========================================================
177      if (present(msg)) print *,trim(msg)
178      print *,'program exits with exit code ', code
179#if (defined (RS6000))
180      call exit_ (code)
181#else
182      call exit (code)
183#endif
184    end subroutine exit_with_status_8
185#endif
186
187
188
189end module extension
190