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