[dragonegg] r176083 - Remove a bunch of huge, unreduced testcases.
Duncan Sands
baldrick at free.fr
Tue Feb 26 02:01:44 PST 2013
Removed: dragonegg/trunk/test/compilator/local/regex.i
URL: http://llvm.org/viewvc/llvm-project/dragonegg/trunk/test/compilator/local/regex.i?rev=176082&view=auto
==============================================================================
--- dragonegg/trunk/test/compilator/local/regex.i (original)
+++ dragonegg/trunk/test/compilator/local/regex.i (removed)
@@ -1,3059 +0,0 @@
-typedef long int ptrdiff_t;
-typedef long unsigned int size_t;
-typedef int wchar_t;
-union wait
- {
- int w_status;
- struct
- {
- unsigned int __w_termsig:7;
- unsigned int __w_coredump:1;
- unsigned int __w_retcode:8;
- unsigned int:16;
- } __wait_terminated;
- struct
- {
- unsigned int __w_stopval:8;
- unsigned int __w_stopsig:8;
- unsigned int:16;
- } __wait_stopped;
- };
-typedef union
- {
- union wait *__uptr;
- int *__iptr;
- } __WAIT_STATUS __attribute__ ((__transparent_union__));
-typedef struct
- {
- int quot;
- int rem;
- } div_t;
-typedef struct
- {
- long int quot;
- long int rem;
- } ldiv_t;
-__extension__ typedef struct
- {
- long long int quot;
- long long int rem;
- } lldiv_t;
-extern size_t __ctype_get_mb_cur_max (void) __attribute__ ((__nothrow__)) ;
-extern double atof (__const char *__nptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1))) ;
-extern int atoi (__const char *__nptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1))) ;
-extern long int atol (__const char *__nptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1))) ;
-__extension__ extern long long int atoll (__const char *__nptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1))) ;
-extern double strtod (__const char *__restrict __nptr,
- char **__restrict __endptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern float strtof (__const char *__restrict __nptr,
- char **__restrict __endptr) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern long double strtold (__const char *__restrict __nptr,
- char **__restrict __endptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern long int strtol (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern unsigned long int strtoul (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-__extension__
-extern long long int strtoq (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-__extension__
-extern unsigned long long int strtouq (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-__extension__
-extern long long int strtoll (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-__extension__
-extern unsigned long long int strtoull (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-typedef struct __locale_struct
-{
- struct locale_data *__locales[13];
- const unsigned short int *__ctype_b;
- const int *__ctype_tolower;
- const int *__ctype_toupper;
- const char *__names[13];
-} *__locale_t;
-typedef __locale_t locale_t;
-extern long int strtol_l (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base,
- __locale_t __loc) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 4))) ;
-extern unsigned long int strtoul_l (__const char *__restrict __nptr,
- char **__restrict __endptr,
- int __base, __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 4))) ;
-__extension__
-extern long long int strtoll_l (__const char *__restrict __nptr,
- char **__restrict __endptr, int __base,
- __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 4))) ;
-__extension__
-extern unsigned long long int strtoull_l (__const char *__restrict __nptr,
- char **__restrict __endptr,
- int __base, __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 4))) ;
-extern double strtod_l (__const char *__restrict __nptr,
- char **__restrict __endptr, __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 3))) ;
-extern float strtof_l (__const char *__restrict __nptr,
- char **__restrict __endptr, __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 3))) ;
-extern long double strtold_l (__const char *__restrict __nptr,
- char **__restrict __endptr,
- __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 3))) ;
-extern char *l64a (long int __n) __attribute__ ((__nothrow__)) ;
-extern long int a64l (__const char *__s)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1))) ;
-typedef unsigned char __u_char;
-typedef unsigned short int __u_short;
-typedef unsigned int __u_int;
-typedef unsigned long int __u_long;
-typedef signed char __int8_t;
-typedef unsigned char __uint8_t;
-typedef signed short int __int16_t;
-typedef unsigned short int __uint16_t;
-typedef signed int __int32_t;
-typedef unsigned int __uint32_t;
-typedef signed long int __int64_t;
-typedef unsigned long int __uint64_t;
-typedef long int __quad_t;
-typedef unsigned long int __u_quad_t;
-typedef unsigned long int __dev_t;
-typedef unsigned int __uid_t;
-typedef unsigned int __gid_t;
-typedef unsigned long int __ino_t;
-typedef unsigned long int __ino64_t;
-typedef unsigned int __mode_t;
-typedef unsigned long int __nlink_t;
-typedef long int __off_t;
-typedef long int __off64_t;
-typedef int __pid_t;
-typedef struct { int __val[2]; } __fsid_t;
-typedef long int __clock_t;
-typedef unsigned long int __rlim_t;
-typedef unsigned long int __rlim64_t;
-typedef unsigned int __id_t;
-typedef long int __time_t;
-typedef unsigned int __useconds_t;
-typedef long int __suseconds_t;
-typedef int __daddr_t;
-typedef long int __swblk_t;
-typedef int __key_t;
-typedef int __clockid_t;
-typedef void * __timer_t;
-typedef long int __blksize_t;
-typedef long int __blkcnt_t;
-typedef long int __blkcnt64_t;
-typedef unsigned long int __fsblkcnt_t;
-typedef unsigned long int __fsblkcnt64_t;
-typedef unsigned long int __fsfilcnt_t;
-typedef unsigned long int __fsfilcnt64_t;
-typedef long int __ssize_t;
-typedef __off64_t __loff_t;
-typedef __quad_t *__qaddr_t;
-typedef char *__caddr_t;
-typedef long int __intptr_t;
-typedef unsigned int __socklen_t;
-typedef __u_char u_char;
-typedef __u_short u_short;
-typedef __u_int u_int;
-typedef __u_long u_long;
-typedef __quad_t quad_t;
-typedef __u_quad_t u_quad_t;
-typedef __fsid_t fsid_t;
-typedef __loff_t loff_t;
-typedef __ino_t ino_t;
-typedef __ino64_t ino64_t;
-typedef __dev_t dev_t;
-typedef __gid_t gid_t;
-typedef __mode_t mode_t;
-typedef __nlink_t nlink_t;
-typedef __uid_t uid_t;
-typedef __off_t off_t;
-typedef __off64_t off64_t;
-typedef __pid_t pid_t;
-typedef __id_t id_t;
-typedef __ssize_t ssize_t;
-typedef __daddr_t daddr_t;
-typedef __caddr_t caddr_t;
-typedef __key_t key_t;
-typedef __clock_t clock_t;
-typedef __time_t time_t;
-typedef __clockid_t clockid_t;
-typedef __timer_t timer_t;
-typedef __useconds_t useconds_t;
-typedef __suseconds_t suseconds_t;
-typedef unsigned long int ulong;
-typedef unsigned short int ushort;
-typedef unsigned int uint;
-typedef int int8_t __attribute__ ((__mode__ (__QI__)));
-typedef int int16_t __attribute__ ((__mode__ (__HI__)));
-typedef int int32_t __attribute__ ((__mode__ (__SI__)));
-typedef int int64_t __attribute__ ((__mode__ (__DI__)));
-typedef unsigned int u_int8_t __attribute__ ((__mode__ (__QI__)));
-typedef unsigned int u_int16_t __attribute__ ((__mode__ (__HI__)));
-typedef unsigned int u_int32_t __attribute__ ((__mode__ (__SI__)));
-typedef unsigned int u_int64_t __attribute__ ((__mode__ (__DI__)));
-typedef int register_t __attribute__ ((__mode__ (__word__)));
-typedef int __sig_atomic_t;
-typedef struct
- {
- unsigned long int __val[(1024 / (8 * sizeof (unsigned long int)))];
- } __sigset_t;
-typedef __sigset_t sigset_t;
-struct timespec
- {
- __time_t tv_sec;
- long int tv_nsec;
- };
-struct timeval
- {
- __time_t tv_sec;
- __suseconds_t tv_usec;
- };
-typedef long int __fd_mask;
-typedef struct
- {
- __fd_mask fds_bits[1024 / (8 * sizeof (__fd_mask))];
- } fd_set;
-typedef __fd_mask fd_mask;
-extern int select (int __nfds, fd_set *__restrict __readfds,
- fd_set *__restrict __writefds,
- fd_set *__restrict __exceptfds,
- struct timeval *__restrict __timeout);
-extern int pselect (int __nfds, fd_set *__restrict __readfds,
- fd_set *__restrict __writefds,
- fd_set *__restrict __exceptfds,
- const struct timespec *__restrict __timeout,
- const __sigset_t *__restrict __sigmask);
-__extension__
-extern unsigned int gnu_dev_major (unsigned long long int __dev)
- __attribute__ ((__nothrow__));
-__extension__
-extern unsigned int gnu_dev_minor (unsigned long long int __dev)
- __attribute__ ((__nothrow__));
-__extension__
-extern unsigned long long int gnu_dev_makedev (unsigned int __major,
- unsigned int __minor)
- __attribute__ ((__nothrow__));
-typedef __blksize_t blksize_t;
-typedef __blkcnt_t blkcnt_t;
-typedef __fsblkcnt_t fsblkcnt_t;
-typedef __fsfilcnt_t fsfilcnt_t;
-typedef __blkcnt64_t blkcnt64_t;
-typedef __fsblkcnt64_t fsblkcnt64_t;
-typedef __fsfilcnt64_t fsfilcnt64_t;
-typedef unsigned long int pthread_t;
-typedef union
-{
- char __size[56];
- long int __align;
-} pthread_attr_t;
-typedef struct __pthread_internal_list
-{
- struct __pthread_internal_list *__prev;
- struct __pthread_internal_list *__next;
-} __pthread_list_t;
-typedef union
-{
- struct __pthread_mutex_s
- {
- int __lock;
- unsigned int __count;
- int __owner;
- unsigned int __nusers;
- int __kind;
- int __spins;
- __pthread_list_t __list;
- } __data;
- char __size[40];
- long int __align;
-} pthread_mutex_t;
-typedef union
-{
- char __size[4];
- int __align;
-} pthread_mutexattr_t;
-typedef union
-{
- struct
- {
- int __lock;
- unsigned int __futex;
- __extension__ unsigned long long int __total_seq;
- __extension__ unsigned long long int __wakeup_seq;
- __extension__ unsigned long long int __woken_seq;
- void *__mutex;
- unsigned int __nwaiters;
- unsigned int __broadcast_seq;
- } __data;
- char __size[48];
- __extension__ long long int __align;
-} pthread_cond_t;
-typedef union
-{
- char __size[4];
- int __align;
-} pthread_condattr_t;
-typedef unsigned int pthread_key_t;
-typedef int pthread_once_t;
-typedef union
-{
- struct
- {
- int __lock;
- unsigned int __nr_readers;
- unsigned int __readers_wakeup;
- unsigned int __writer_wakeup;
- unsigned int __nr_readers_queued;
- unsigned int __nr_writers_queued;
- int __writer;
- int __shared;
- unsigned long int __pad1;
- unsigned long int __pad2;
- unsigned int __flags;
- } __data;
- char __size[56];
- long int __align;
-} pthread_rwlock_t;
-typedef union
-{
- char __size[8];
- long int __align;
-} pthread_rwlockattr_t;
-typedef volatile int pthread_spinlock_t;
-typedef union
-{
- char __size[32];
- long int __align;
-} pthread_barrier_t;
-typedef union
-{
- char __size[4];
- int __align;
-} pthread_barrierattr_t;
-extern long int random (void) __attribute__ ((__nothrow__));
-extern void srandom (unsigned int __seed) __attribute__ ((__nothrow__));
-extern char *initstate (unsigned int __seed, char *__statebuf,
- size_t __statelen) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern char *setstate (char *__statebuf) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-struct random_data
- {
- int32_t *fptr;
- int32_t *rptr;
- int32_t *state;
- int rand_type;
- int rand_deg;
- int rand_sep;
- int32_t *end_ptr;
- };
-extern int random_r (struct random_data *__restrict __buf,
- int32_t *__restrict __result) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int srandom_r (unsigned int __seed, struct random_data *__buf)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern int initstate_r (unsigned int __seed, char *__restrict __statebuf,
- size_t __statelen,
- struct random_data *__restrict __buf)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2, 4)));
-extern int setstate_r (char *__restrict __statebuf,
- struct random_data *__restrict __buf)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int rand (void) __attribute__ ((__nothrow__));
-extern void srand (unsigned int __seed) __attribute__ ((__nothrow__));
-extern int rand_r (unsigned int *__seed) __attribute__ ((__nothrow__));
-extern double drand48 (void) __attribute__ ((__nothrow__));
-extern double erand48 (unsigned short int __xsubi[3]) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern long int lrand48 (void) __attribute__ ((__nothrow__));
-extern long int nrand48 (unsigned short int __xsubi[3])
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern long int mrand48 (void) __attribute__ ((__nothrow__));
-extern long int jrand48 (unsigned short int __xsubi[3])
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern void srand48 (long int __seedval) __attribute__ ((__nothrow__));
-extern unsigned short int *seed48 (unsigned short int __seed16v[3])
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern void lcong48 (unsigned short int __param[7]) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-struct drand48_data
- {
- unsigned short int __x[3];
- unsigned short int __old_x[3];
- unsigned short int __c;
- unsigned short int __init;
- unsigned long long int __a;
- };
-extern int drand48_r (struct drand48_data *__restrict __buffer,
- double *__restrict __result) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int erand48_r (unsigned short int __xsubi[3],
- struct drand48_data *__restrict __buffer,
- double *__restrict __result) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int lrand48_r (struct drand48_data *__restrict __buffer,
- long int *__restrict __result)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int nrand48_r (unsigned short int __xsubi[3],
- struct drand48_data *__restrict __buffer,
- long int *__restrict __result)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int mrand48_r (struct drand48_data *__restrict __buffer,
- long int *__restrict __result)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int jrand48_r (unsigned short int __xsubi[3],
- struct drand48_data *__restrict __buffer,
- long int *__restrict __result)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int srand48_r (long int __seedval, struct drand48_data *__buffer)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern int seed48_r (unsigned short int __seed16v[3],
- struct drand48_data *__buffer) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int lcong48_r (unsigned short int __param[7],
- struct drand48_data *__buffer)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *malloc (size_t __size) __attribute__ ((__nothrow__)) __attribute__ ((__malloc__)) ;
-extern void *calloc (size_t __nmemb, size_t __size)
- __attribute__ ((__nothrow__)) __attribute__ ((__malloc__)) ;
-extern void *realloc (void *__ptr, size_t __size)
- __attribute__ ((__nothrow__)) __attribute__ ((__warn_unused_result__));
-extern void free (void *__ptr) __attribute__ ((__nothrow__));
-extern void cfree (void *__ptr) __attribute__ ((__nothrow__));
-extern void *alloca (size_t __size) __attribute__ ((__nothrow__));
-extern void *valloc (size_t __size) __attribute__ ((__nothrow__)) __attribute__ ((__malloc__)) ;
-extern int posix_memalign (void **__memptr, size_t __alignment, size_t __size)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern void abort (void) __attribute__ ((__nothrow__)) __attribute__ ((__noreturn__));
-extern int atexit (void (*__func) (void)) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern int at_quick_exit (void (*__func) (void)) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern int on_exit (void (*__func) (int __status, void *__arg), void *__arg)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern void exit (int __status) __attribute__ ((__nothrow__)) __attribute__ ((__noreturn__));
-extern void quick_exit (int __status) __attribute__ ((__nothrow__)) __attribute__ ((__noreturn__));
-extern void _Exit (int __status) __attribute__ ((__nothrow__)) __attribute__ ((__noreturn__));
-extern char *getenv (__const char *__name) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern char *__secure_getenv (__const char *__name)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern int putenv (char *__string) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern int setenv (__const char *__name, __const char *__value, int __replace)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern int unsetenv (__const char *__name) __attribute__ ((__nothrow__));
-extern int clearenv (void) __attribute__ ((__nothrow__));
-extern char *mktemp (char *__template) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern int mkstemp (char *__template) __attribute__ ((__nonnull__ (1))) ;
-extern int mkstemp64 (char *__template) __attribute__ ((__nonnull__ (1))) ;
-extern char *mkdtemp (char *__template) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern int mkostemp (char *__template, int __flags) __attribute__ ((__nonnull__ (1))) ;
-extern int mkostemp64 (char *__template, int __flags) __attribute__ ((__nonnull__ (1))) ;
-extern int system (__const char *__command) ;
-extern char *canonicalize_file_name (__const char *__name)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern char *realpath (__const char *__restrict __name,
- char *__restrict __resolved) __attribute__ ((__nothrow__)) ;
-typedef int (*__compar_fn_t) (__const void *, __const void *);
-typedef __compar_fn_t comparison_fn_t;
-typedef int (*__compar_d_fn_t) (__const void *, __const void *, void *);
-extern void *bsearch (__const void *__key, __const void *__base,
- size_t __nmemb, size_t __size, __compar_fn_t __compar)
- __attribute__ ((__nonnull__ (1, 2, 5))) ;
-extern void qsort (void *__base, size_t __nmemb, size_t __size,
- __compar_fn_t __compar) __attribute__ ((__nonnull__ (1, 4)));
-extern void qsort_r (void *__base, size_t __nmemb, size_t __size,
- __compar_d_fn_t __compar, void *__arg)
- __attribute__ ((__nonnull__ (1, 4)));
-extern int abs (int __x) __attribute__ ((__nothrow__)) __attribute__ ((__const__)) ;
-extern long int labs (long int __x) __attribute__ ((__nothrow__)) __attribute__ ((__const__)) ;
-__extension__ extern long long int llabs (long long int __x)
- __attribute__ ((__nothrow__)) __attribute__ ((__const__)) ;
-extern div_t div (int __numer, int __denom)
- __attribute__ ((__nothrow__)) __attribute__ ((__const__)) ;
-extern ldiv_t ldiv (long int __numer, long int __denom)
- __attribute__ ((__nothrow__)) __attribute__ ((__const__)) ;
-__extension__ extern lldiv_t lldiv (long long int __numer,
- long long int __denom)
- __attribute__ ((__nothrow__)) __attribute__ ((__const__)) ;
-extern char *ecvt (double __value, int __ndigit, int *__restrict __decpt,
- int *__restrict __sign) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4))) ;
-extern char *fcvt (double __value, int __ndigit, int *__restrict __decpt,
- int *__restrict __sign) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4))) ;
-extern char *gcvt (double __value, int __ndigit, char *__buf)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3))) ;
-extern char *qecvt (long double __value, int __ndigit,
- int *__restrict __decpt, int *__restrict __sign)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4))) ;
-extern char *qfcvt (long double __value, int __ndigit,
- int *__restrict __decpt, int *__restrict __sign)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4))) ;
-extern char *qgcvt (long double __value, int __ndigit, char *__buf)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3))) ;
-extern int ecvt_r (double __value, int __ndigit, int *__restrict __decpt,
- int *__restrict __sign, char *__restrict __buf,
- size_t __len) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4, 5)));
-extern int fcvt_r (double __value, int __ndigit, int *__restrict __decpt,
- int *__restrict __sign, char *__restrict __buf,
- size_t __len) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4, 5)));
-extern int qecvt_r (long double __value, int __ndigit,
- int *__restrict __decpt, int *__restrict __sign,
- char *__restrict __buf, size_t __len)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4, 5)));
-extern int qfcvt_r (long double __value, int __ndigit,
- int *__restrict __decpt, int *__restrict __sign,
- char *__restrict __buf, size_t __len)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (3, 4, 5)));
-extern int mblen (__const char *__s, size_t __n) __attribute__ ((__nothrow__)) ;
-extern int mbtowc (wchar_t *__restrict __pwc,
- __const char *__restrict __s, size_t __n) __attribute__ ((__nothrow__)) ;
-extern int wctomb (char *__s, wchar_t __wchar) __attribute__ ((__nothrow__)) ;
-extern size_t mbstowcs (wchar_t *__restrict __pwcs,
- __const char *__restrict __s, size_t __n) __attribute__ ((__nothrow__));
-extern size_t wcstombs (char *__restrict __s,
- __const wchar_t *__restrict __pwcs, size_t __n)
- __attribute__ ((__nothrow__));
-extern int rpmatch (__const char *__response) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1))) ;
-extern int getsubopt (char **__restrict __optionp,
- char *__const *__restrict __tokens,
- char **__restrict __valuep)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2, 3))) ;
-extern void setkey (__const char *__key) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern int posix_openpt (int __oflag) ;
-extern int grantpt (int __fd) __attribute__ ((__nothrow__));
-extern int unlockpt (int __fd) __attribute__ ((__nothrow__));
-extern char *ptsname (int __fd) __attribute__ ((__nothrow__)) ;
-extern int ptsname_r (int __fd, char *__buf, size_t __buflen)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern int getpt (void);
-extern int getloadavg (double __loadavg[], int __nelem)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern void *memcpy (void *__restrict __dest,
- __const void *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *memmove (void *__dest, __const void *__src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *memccpy (void *__restrict __dest, __const void *__restrict __src,
- int __c, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *memset (void *__s, int __c, size_t __n) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern int memcmp (__const void *__s1, __const void *__s2, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *memchr (__const void *__s, int __c, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern void *rawmemchr (__const void *__s, int __c)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern void *memrchr (__const void *__s, int __c, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern char *strcpy (char *__restrict __dest, __const char *__restrict __src)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strncpy (char *__restrict __dest,
- __const char *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strcat (char *__restrict __dest, __const char *__restrict __src)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strncat (char *__restrict __dest, __const char *__restrict __src,
- size_t __n) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int strcmp (__const char *__s1, __const char *__s2)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int strncmp (__const char *__s1, __const char *__s2, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int strcoll (__const char *__s1, __const char *__s2)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern size_t strxfrm (char *__restrict __dest,
- __const char *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern int strcoll_l (__const char *__s1, __const char *__s2, __locale_t __l)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2, 3)));
-extern size_t strxfrm_l (char *__dest, __const char *__src, size_t __n,
- __locale_t __l) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2, 4)));
-extern char *strdup (__const char *__s)
- __attribute__ ((__nothrow__)) __attribute__ ((__malloc__)) __attribute__ ((__nonnull__ (1)));
-extern char *strndup (__const char *__string, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__malloc__)) __attribute__ ((__nonnull__ (1)));
-extern char *strchr (__const char *__s, int __c)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern char *strrchr (__const char *__s, int __c)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern char *strchrnul (__const char *__s, int __c)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern size_t strcspn (__const char *__s, __const char *__reject)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern size_t strspn (__const char *__s, __const char *__accept)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strpbrk (__const char *__s, __const char *__accept)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strstr (__const char *__haystack, __const char *__needle)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strtok (char *__restrict __s, __const char *__restrict __delim)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern char *__strtok_r (char *__restrict __s,
- __const char *__restrict __delim,
- char **__restrict __save_ptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2, 3)));
-extern char *strtok_r (char *__restrict __s, __const char *__restrict __delim,
- char **__restrict __save_ptr)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2, 3)));
-extern char *strcasestr (__const char *__haystack, __const char *__needle)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *memmem (__const void *__haystack, size_t __haystacklen,
- __const void *__needle, size_t __needlelen)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 3)));
-extern void *__mempcpy (void *__restrict __dest,
- __const void *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void *mempcpy (void *__restrict __dest,
- __const void *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern size_t strlen (__const char *__s)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern size_t strnlen (__const char *__string, size_t __maxlen)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern char *strerror (int __errnum) __attribute__ ((__nothrow__));
-extern char *strerror_r (int __errnum, char *__buf, size_t __buflen)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (2)));
-extern char *strerror_l (int __errnum, __locale_t __l) __attribute__ ((__nothrow__));
-extern void __bzero (void *__s, size_t __n) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern void bcopy (__const void *__src, void *__dest, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern void bzero (void *__s, size_t __n) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern int bcmp (__const void *__s1, __const void *__s2, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *index (__const char *__s, int __c)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern char *rindex (__const char *__s, int __c)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1)));
-extern int ffs (int __i) __attribute__ ((__nothrow__)) __attribute__ ((__const__));
-extern int ffsl (long int __l) __attribute__ ((__nothrow__)) __attribute__ ((__const__));
-__extension__ extern int ffsll (long long int __ll)
- __attribute__ ((__nothrow__)) __attribute__ ((__const__));
-extern int strcasecmp (__const char *__s1, __const char *__s2)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int strncasecmp (__const char *__s1, __const char *__s2, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int strcasecmp_l (__const char *__s1, __const char *__s2,
- __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2, 3)));
-extern int strncasecmp_l (__const char *__s1, __const char *__s2,
- size_t __n, __locale_t __loc)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2, 4)));
-extern char *strsep (char **__restrict __stringp,
- __const char *__restrict __delim)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strsignal (int __sig) __attribute__ ((__nothrow__));
-extern char *__stpcpy (char *__restrict __dest, __const char *__restrict __src)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *stpcpy (char *__restrict __dest, __const char *__restrict __src)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *__stpncpy (char *__restrict __dest,
- __const char *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *stpncpy (char *__restrict __dest,
- __const char *__restrict __src, size_t __n)
- __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1, 2)));
-extern int strverscmp (__const char *__s1, __const char *__s2)
- __attribute__ ((__nothrow__)) __attribute__ ((__pure__)) __attribute__ ((__nonnull__ (1, 2)));
-extern char *strfry (char *__string) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern void *memfrob (void *__s, size_t __n) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-extern char *basename (__const char *__filename) __attribute__ ((__nothrow__)) __attribute__ ((__nonnull__ (1)));
-typedef long int s_reg_t;
-typedef unsigned long int active_reg_t;
-typedef unsigned long int reg_syntax_t;
-extern reg_syntax_t xre_syntax_options;
-typedef enum
-{
- REG_ENOSYS = -1,
- REG_NOERROR = 0,
- REG_NOMATCH,
- REG_BADPAT,
- REG_ECOLLATE,
- REG_ECTYPE,
- REG_EESCAPE,
- REG_ESUBREG,
- REG_EBRACK,
- REG_EPAREN,
- REG_EBRACE,
- REG_BADBR,
- REG_ERANGE,
- REG_ESPACE,
- REG_BADRPT,
- REG_EEND,
- REG_ESIZE,
- REG_ERPAREN
-} reg_errcode_t;
-struct re_pattern_buffer
-{
- unsigned char *buffer;
- unsigned long int allocated;
- unsigned long int used;
- reg_syntax_t syntax;
- char *fastmap;
- char * translate;
- size_t re_nsub;
- unsigned can_be_null : 1;
- unsigned regs_allocated : 2;
- unsigned fastmap_accurate : 1;
- unsigned no_sub : 1;
- unsigned not_bol : 1;
- unsigned not_eol : 1;
- unsigned newline_anchor : 1;
-};
-typedef struct re_pattern_buffer regex_t;
-typedef int regoff_t;
-struct re_registers
-{
- unsigned num_regs;
- regoff_t *start;
- regoff_t *end;
-};
-typedef struct
-{
- regoff_t rm_so;
- regoff_t rm_eo;
-} regmatch_t;
-extern reg_syntax_t xre_set_syntax (reg_syntax_t syntax);
-extern const char *xre_compile_pattern (const char *pattern, size_t length,
- struct re_pattern_buffer *buffer);
-extern int xre_compile_fastmap (struct re_pattern_buffer *buffer);
-extern int xre_search (struct re_pattern_buffer *buffer, const char *string,
- int length, int start, int range,
- struct re_registers *regs);
-extern int xre_search_2 (struct re_pattern_buffer *buffer, const char *string1,
- int length1, const char *string2, int length2,
- int start, int range, struct re_registers *regs,
- int stop);
-extern int xre_match (struct re_pattern_buffer *buffer, const char *string,
- int length, int start, struct re_registers *regs);
-extern int xre_match_2 (struct re_pattern_buffer *buffer, const char *string1,
- int length1, const char *string2, int length2,
- int start, struct re_registers *regs, int stop);
-extern void xre_set_registers (struct re_pattern_buffer *buffer,
- struct re_registers *regs,
- unsigned num_regs, regoff_t *starts,
- regoff_t *ends);
-extern char *xre_comp (const char *);
-extern int xre_exec (const char *);
-extern int xregcomp (regex_t *__restrict __preg,
- const char *__restrict __pattern,
- int __cflags);
-__extension__
-extern int xregexec (const regex_t *__restrict __preg,
- const char *__restrict __string, size_t __nmatch,
- regmatch_t __pmatch[__restrict],
- int __eflags);
-extern size_t xregerror (int __errcode, const regex_t *__preg,
- char *__errbuf, size_t __errbuf_size);
-extern void xregfree (regex_t *__preg);
-enum
-{
- _ISupper = ((0) < 8 ? ((1 << (0)) << 8) : ((1 << (0)) >> 8)),
- _ISlower = ((1) < 8 ? ((1 << (1)) << 8) : ((1 << (1)) >> 8)),
- _ISalpha = ((2) < 8 ? ((1 << (2)) << 8) : ((1 << (2)) >> 8)),
- _ISdigit = ((3) < 8 ? ((1 << (3)) << 8) : ((1 << (3)) >> 8)),
- _ISxdigit = ((4) < 8 ? ((1 << (4)) << 8) : ((1 << (4)) >> 8)),
- _ISspace = ((5) < 8 ? ((1 << (5)) << 8) : ((1 << (5)) >> 8)),
- _ISprint = ((6) < 8 ? ((1 << (6)) << 8) : ((1 << (6)) >> 8)),
- _ISgraph = ((7) < 8 ? ((1 << (7)) << 8) : ((1 << (7)) >> 8)),
- _ISblank = ((8) < 8 ? ((1 << (8)) << 8) : ((1 << (8)) >> 8)),
- _IScntrl = ((9) < 8 ? ((1 << (9)) << 8) : ((1 << (9)) >> 8)),
- _ISpunct = ((10) < 8 ? ((1 << (10)) << 8) : ((1 << (10)) >> 8)),
- _ISalnum = ((11) < 8 ? ((1 << (11)) << 8) : ((1 << (11)) >> 8))
-};
-extern __const unsigned short int **__ctype_b_loc (void)
- __attribute__ ((__nothrow__)) __attribute__ ((__const));
-extern __const __int32_t **__ctype_tolower_loc (void)
- __attribute__ ((__nothrow__)) __attribute__ ((__const));
-extern __const __int32_t **__ctype_toupper_loc (void)
- __attribute__ ((__nothrow__)) __attribute__ ((__const));
-extern int isalnum (int) __attribute__ ((__nothrow__));
-extern int isalpha (int) __attribute__ ((__nothrow__));
-extern int iscntrl (int) __attribute__ ((__nothrow__));
-extern int isdigit (int) __attribute__ ((__nothrow__));
-extern int islower (int) __attribute__ ((__nothrow__));
-extern int isgraph (int) __attribute__ ((__nothrow__));
-extern int isprint (int) __attribute__ ((__nothrow__));
-extern int ispunct (int) __attribute__ ((__nothrow__));
-extern int isspace (int) __attribute__ ((__nothrow__));
-extern int isupper (int) __attribute__ ((__nothrow__));
-extern int isxdigit (int) __attribute__ ((__nothrow__));
-extern int tolower (int __c) __attribute__ ((__nothrow__));
-extern int toupper (int __c) __attribute__ ((__nothrow__));
-extern int isblank (int) __attribute__ ((__nothrow__));
-extern int isctype (int __c, int __mask) __attribute__ ((__nothrow__));
-extern int isascii (int __c) __attribute__ ((__nothrow__));
-extern int toascii (int __c) __attribute__ ((__nothrow__));
-extern int _toupper (int) __attribute__ ((__nothrow__));
-extern int _tolower (int) __attribute__ ((__nothrow__));
-extern int isalnum_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isalpha_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int iscntrl_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isdigit_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int islower_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isgraph_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isprint_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int ispunct_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isspace_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isupper_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isxdigit_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int isblank_l (int, __locale_t) __attribute__ ((__nothrow__));
-extern int __tolower_l (int __c, __locale_t __l) __attribute__ ((__nothrow__));
-extern int tolower_l (int __c, __locale_t __l) __attribute__ ((__nothrow__));
-extern int __toupper_l (int __c, __locale_t __l) __attribute__ ((__nothrow__));
-extern int toupper_l (int __c, __locale_t __l) __attribute__ ((__nothrow__));
-static char re_syntax_table[256];
-static void init_syntax_once (void);
-static void
-init_syntax_once (void)
-{
- register int c;
- static int done = 0;
- if (done)
- return;
- (memset (re_syntax_table, '\0', sizeof re_syntax_table), (re_syntax_table));
- for (c = 0; c < 256; ++c)
- if ((1 && ((*__ctype_b_loc ())[(int) ((c))] & (unsigned short int) _ISalnum)))
- re_syntax_table[c] = 1;
- re_syntax_table['_'] = 1;
- done = 1;
-}
-typedef char boolean;
-static reg_errcode_t byte_regex_compile (const char *pattern, size_t size,
- reg_syntax_t syntax,
- struct re_pattern_buffer *bufp);
-static int byte_re_match_2_internal (struct re_pattern_buffer *bufp,
- const char *string1, int size1,
- const char *string2, int size2,
- int pos,
- struct re_registers *regs,
- int stop);
-static int byte_re_search_2 (struct re_pattern_buffer *bufp,
- const char *string1, int size1,
- const char *string2, int size2,
- int startpos, int range,
- struct re_registers *regs, int stop);
-static int byte_re_compile_fastmap (struct re_pattern_buffer *bufp);
-typedef enum
-{
- no_op = 0,
- succeed,
- exactn,
- anychar,
- charset,
- charset_not,
- start_memory,
- stop_memory,
- duplicate,
- begline,
- endline,
- begbuf,
- endbuf,
- jump,
- jump_past_alt,
- on_failure_jump,
- on_failure_keep_string_jump,
- pop_failure_jump,
- maybe_pop_jump,
- dummy_failure_jump,
- push_dummy_failure,
- succeed_n,
- jump_n,
- set_number_at,
- wordchar,
- notwordchar,
- wordbeg,
- wordend,
- wordbound,
- notwordbound
-} re_opcode_t;
-int xre_max_failures = 4000;
-union byte_fail_stack_elt
-{
- unsigned char *pointer;
- int integer;
-};
-typedef union byte_fail_stack_elt byte_fail_stack_elt_t;
-typedef struct
-{
- byte_fail_stack_elt_t *stack;
- unsigned size;
- unsigned avail;
-} byte_fail_stack_type;
-typedef union
-{
- byte_fail_stack_elt_t word;
- struct
- {
- unsigned match_null_string_p : 2;
- unsigned is_active : 1;
- unsigned matched_something : 1;
- unsigned ever_matched_something : 1;
- } bits;
-} byte_register_info_type;
-static char byte_reg_unset_dummy;
-static void byte_store_op1 (re_opcode_t op, unsigned char *loc, int arg);
-static void byte_store_op2 (re_opcode_t op, unsigned char *loc,
- int arg1, int arg2);
-static void byte_insert_op1 (re_opcode_t op, unsigned char *loc,
- int arg, unsigned char *end);
-static void byte_insert_op2 (re_opcode_t op, unsigned char *loc,
- int arg1, int arg2, unsigned char *end);
-static boolean byte_at_begline_loc_p (const char *pattern,
- const char *p,
- reg_syntax_t syntax);
-static boolean byte_at_endline_loc_p (const char *p,
- const char *pend,
- reg_syntax_t syntax);
-static reg_errcode_t byte_compile_range (unsigned int range_start,
- const char **p_ptr,
- const char *pend,
- char *translate,
- reg_syntax_t syntax,
- unsigned char *b);
-typedef unsigned regnum_t;
-typedef long pattern_offset_t;
-typedef struct
-{
- pattern_offset_t begalt_offset;
- pattern_offset_t fixup_alt_jump;
- pattern_offset_t inner_group_offset;
- pattern_offset_t laststart_offset;
- regnum_t regnum;
-} compile_stack_elt_t;
-typedef struct
-{
- compile_stack_elt_t *stack;
- unsigned size;
- unsigned avail;
-} compile_stack_type;
-static boolean group_in_compile_stack (compile_stack_type compile_stack,
- regnum_t regnum);
-static reg_errcode_t
-byte_regex_compile (const char *pattern,
- size_t size, reg_syntax_t syntax,
- struct re_pattern_buffer *bufp)
-{
- register unsigned char c, c1;
- const char *p1;
- register unsigned char *b;
- compile_stack_type compile_stack;
- const char *p = pattern;
- const char *pend = pattern + size;
- char * translate = bufp->translate;
- unsigned char *pending_exact = 0;
- unsigned char *laststart = 0;
- unsigned char *begalt;
- unsigned char *fixup_alt_jump = 0;
- regnum_t regnum = 0;
- compile_stack.stack = ((compile_stack_elt_t *) malloc ((32) * sizeof (compile_stack_elt_t)));
- if (compile_stack.stack == ((void *)0))
- {
- return REG_ESPACE;
- }
- compile_stack.size = 32;
- compile_stack.avail = 0;
- bufp->syntax = syntax;
- bufp->fastmap_accurate = 0;
- bufp->not_bol = bufp->not_eol = 0;
- bufp->used = 0;
- bufp->re_nsub = 0;
- init_syntax_once ();
- if (bufp->allocated == 0)
- {
- if (bufp->buffer)
- {
- ((bufp->buffer) = (unsigned char *) realloc (bufp->buffer, ((32 * sizeof(unsigned char))) * sizeof (unsigned char)));
- }
- else
- {
- bufp->buffer = ((unsigned char *) malloc (((32 * sizeof(unsigned char)) / sizeof(unsigned char)) * sizeof (unsigned char)));
- }
- if (!bufp->buffer) return (free (compile_stack.stack), REG_ESPACE);
- bufp->allocated = (32 * sizeof(unsigned char));
- }
- begalt = b = bufp->buffer;
- while (p != pend)
- {
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- switch (c)
- {
- case '^':
- {
- if (
- p == pattern + 1
- || syntax & (((((unsigned long int) 1) << 1) << 1) << 1)
- || byte_at_begline_loc_p (pattern, p, syntax))
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (begline); } while (0);
- else
- goto normal_char;
- }
- break;
- case '$':
- {
- if (
- p == pend
- || syntax & (((((unsigned long int) 1) << 1) << 1) << 1)
- || byte_at_endline_loc_p (p, pend, syntax))
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (endline); } while (0);
- else
- goto normal_char;
- }
- break;
- case '+':
- case '?':
- if ((syntax & (((unsigned long int) 1) << 1))
- || (syntax & ((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- goto normal_char;
- handle_plus:
- case '*':
- if (!laststart)
- {
- if (syntax & (((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1))
- return (free (compile_stack.stack), REG_BADRPT);
- else if (!(syntax & ((((((unsigned long int) 1) << 1) << 1) << 1) << 1)))
- goto normal_char;
- }
- {
- boolean keep_string_p = 0;
- char zero_times_ok = 0, many_times_ok = 0;
- for (;;)
- {
- zero_times_ok |= c != '+';
- many_times_ok |= c != '?';
- if (p == pend)
- break;
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- if (c == '*'
- || (!(syntax & (((unsigned long int) 1) << 1)) && (c == '+' || c == '?')))
- ;
- else if (syntax & (((unsigned long int) 1) << 1) && c == '\\')
- {
- if (p == pend) return (free (compile_stack.stack), REG_EESCAPE);
- do {if (p == pend) return REG_EEND; c1 = (unsigned char) *p++; if (translate) c1 = (unsigned char) translate[c1]; } while (0);
- if (!(c1 == '+' || c1 == '?'))
- {
- p--;
- p--;
- break;
- }
- c = c1;
- }
- else
- {
- p--;
- break;
- }
- }
- if (!laststart)
- break;
- if (many_times_ok)
- {
- ;
- while ((unsigned long) (b - bufp->buffer + (1 + 2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- if ((translate ? (char) translate[(unsigned char) (*(p - 2))] : (char) (*(p - 2))) == (translate ? (char) translate[(unsigned char) ('.')] : (char) ('.'))
- && zero_times_ok
- && p < pend && (translate ? (char) translate[(unsigned char) (*p)] : (char) (*p)) == (translate ? (char) translate[(unsigned char) ('\n')] : (char) ('\n'))
- && !(syntax & ((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- {
- byte_store_op1 (jump, b, (int) ((laststart) - (b) - (1 + 2)));
- keep_string_p = 1;
- }
- else
- byte_store_op1 (maybe_pop_jump, b, (int) ((laststart - (1 + 2)) - (b) - (1 + 2)));
- b += 1 + 2;
- }
- while ((unsigned long) (b - bufp->buffer + (1 + 2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- byte_insert_op1 (keep_string_p ? on_failure_keep_string_jump : on_failure_jump, laststart, (int) ((b + 1 + 2) - (laststart) - (1 + 2)), b);
- pending_exact = 0;
- b += 1 + 2;
- if (!zero_times_ok)
- {
- while ((unsigned long) (b - bufp->buffer + (1 + 2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- byte_insert_op1 (dummy_failure_jump, laststart, (int) ((laststart + 2 + 2 * 2) - (laststart) - (1 + 2)), b);
- b += 1 + 2;
- }
- }
- break;
- case '.':
- laststart = b;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (anychar); } while (0);
- break;
- case '[':
- {
- boolean had_char_class = 0;
- unsigned int range_start = 0xffffffff;
- if (p == pend) return (free (compile_stack.stack), REG_EBRACK);
- while ((unsigned long) (b - bufp->buffer + (34)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- laststart = b;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (*p == '^' ? charset_not : charset); } while (0);
- if (*p == '^')
- p++;
- p1 = p;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) ((1 << 8) / 8); } while (0);
- (memset (b, '\0', (1 << 8) / 8), (b));
- if ((re_opcode_t) b[-2] == charset_not
- && (syntax & ((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- (b[((unsigned char) ('\n')) / 8] |= 1 << (((unsigned char) '\n') % 8));
- for (;;)
- {
- if (p == pend) return (free (compile_stack.stack), REG_EBRACK);
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- if ((syntax & ((unsigned long int) 1)) && c == '\\')
- {
- if (p == pend) return (free (compile_stack.stack), REG_EESCAPE);
- do {if (p == pend) return REG_EEND; c1 = (unsigned char) *p++; if (translate) c1 = (unsigned char) translate[c1]; } while (0);
- (b[((unsigned char) (c1)) / 8] |= 1 << (((unsigned char) c1) % 8));
- range_start = c1;
- continue;
- }
- if (c == ']' && p != p1 + 1)
- break;
- if (had_char_class && c == '-' && *p != ']')
- return (free (compile_stack.stack), REG_ERANGE);
- if (c == '-'
- && !(p - 2 >= pattern && p[-2] == '[')
- && !(p - 3 >= pattern && p[-3] == '[' && p[-2] == '^')
- && *p != ']')
- {
- reg_errcode_t ret
- = byte_compile_range (range_start, &p, pend, translate,
- syntax, b);
- if (ret != REG_NOERROR) return (free (compile_stack.stack), ret);
- range_start = 0xffffffff;
- }
- else if (p[0] == '-' && p[1] != ']')
- {
- reg_errcode_t ret;
- do {if (p == pend) return REG_EEND; c1 = (unsigned char) *p++; if (translate) c1 = (unsigned char) translate[c1]; } while (0);
- ret = byte_compile_range (c, &p, pend, translate, syntax, b);
- if (ret != REG_NOERROR) return (free (compile_stack.stack), ret);
- range_start = 0xffffffff;
- }
- else if (syntax & ((((unsigned long int) 1) << 1) << 1) && c == '[' && *p == ':')
- {
- char str[6 + 1];
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- c1 = 0;
- if (p == pend) return (free (compile_stack.stack), REG_EBRACK);
- for (;;)
- {
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- if ((c == ':' && *p == ']') || p == pend)
- break;
- if (c1 < 6)
- str[c1++] = c;
- else
- str[0] = '\0';
- }
- str[c1] = '\0';
- if (c == ':' && *p == ']')
- {
- int ch;
- boolean is_alnum = ((strcmp (str, "alnum") == 0));
- boolean is_alpha = ((strcmp (str, "alpha") == 0));
- boolean is_blank = ((strcmp (str, "blank") == 0));
- boolean is_cntrl = ((strcmp (str, "cntrl") == 0));
- boolean is_digit = ((strcmp (str, "digit") == 0));
- boolean is_graph = ((strcmp (str, "graph") == 0));
- boolean is_lower = ((strcmp (str, "lower") == 0));
- boolean is_print = ((strcmp (str, "print") == 0));
- boolean is_punct = ((strcmp (str, "punct") == 0));
- boolean is_space = ((strcmp (str, "space") == 0));
- boolean is_upper = ((strcmp (str, "upper") == 0));
- boolean is_xdigit = ((strcmp (str, "xdigit") == 0));
- if (!(((strcmp (str, "alpha") == 0)) || ((strcmp (str, "upper") == 0)) || ((strcmp (str, "lower") == 0)) || ((strcmp (str, "digit") == 0)) || ((strcmp (str, "alnum") == 0)) || ((strcmp (str, "xdigit") == 0)) || ((strcmp (str, "space") == 0)) || ((strcmp (str, "print") == 0)) || ((strcmp (str, "punct") == 0)) || ((strcmp (str, "graph") == 0)) || ((strcmp (str, "cntrl") == 0)) || ((strcmp (str, "blank") == 0))))
- return (free (compile_stack.stack), REG_ECTYPE);
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- if (p == pend) return (free (compile_stack.stack), REG_EBRACK);
- for (ch = 0; ch < 1 << 8; ch++)
- {
- if ( (is_alnum && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISalnum)))
- || (is_alpha && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISalpha)))
- || (is_blank && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISblank)))
- || (is_cntrl && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _IScntrl))))
- (b[((unsigned char) (ch)) / 8] |= 1 << (((unsigned char) ch) % 8));
- if ( (is_digit && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISdigit)))
- || (is_graph && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISgraph)))
- || (is_lower && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISlower)))
- || (is_print && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISprint))))
- (b[((unsigned char) (ch)) / 8] |= 1 << (((unsigned char) ch) % 8));
- if ( (is_punct && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISpunct)))
- || (is_space && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISspace)))
- || (is_upper && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISupper)))
- || (is_xdigit && (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISxdigit))))
- (b[((unsigned char) (ch)) / 8] |= 1 << (((unsigned char) ch) % 8));
- if ( translate && (is_upper || is_lower)
- && ((1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISupper)) || (1 && ((*__ctype_b_loc ())[(int) ((ch))] & (unsigned short int) _ISlower))))
- (b[((unsigned char) (ch)) / 8] |= 1 << (((unsigned char) ch) % 8));
- }
- had_char_class = 1;
- }
- else
- {
- c1++;
- while (c1--)
- p--;
- (b[((unsigned char) ('[')) / 8] |= 1 << (((unsigned char) '[') % 8));
- (b[((unsigned char) (':')) / 8] |= 1 << (((unsigned char) ':') % 8));
- range_start = ':';
- had_char_class = 0;
- }
- }
- else if (syntax & ((((unsigned long int) 1) << 1) << 1) && c == '[' && *p == '=')
- {
- unsigned char str[16 + 1];
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- c1 = 0;
- if (p == pend) return (free (compile_stack.stack), REG_EBRACK);
- for (;;)
- {
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- if ((c == '=' && *p == ']') || p == pend)
- break;
- if (c1 < 16)
- str[c1++] = c;
- else
- str[0] = '\0';
- }
- str[c1] = '\0';
- if (c == '=' && *p == ']' && str[0] != '\0')
- {
- {
- if (c1 != 1)
- return (free (compile_stack.stack), REG_ECOLLATE);
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- (b[((unsigned char) (str[0])) / 8] |= 1 << (((unsigned char) str[0]) % 8));
- }
- had_char_class = 1;
- }
- else
- {
- c1++;
- while (c1--)
- p--;
- (b[((unsigned char) ('[')) / 8] |= 1 << (((unsigned char) '[') % 8));
- (b[((unsigned char) ('=')) / 8] |= 1 << (((unsigned char) '=') % 8));
- range_start = '=';
- had_char_class = 0;
- }
- }
- else if (syntax & ((((unsigned long int) 1) << 1) << 1) && c == '[' && *p == '.')
- {
- unsigned char str[128];
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- c1 = 0;
- if (p == pend) return (free (compile_stack.stack), REG_EBRACK);
- for (;;)
- {
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- if ((c == '.' && *p == ']') || p == pend)
- break;
- if (c1 < sizeof (str))
- str[c1++] = c;
- else
- str[0] = '\0';
- }
- str[c1] = '\0';
- if (c == '.' && *p == ']' && str[0] != '\0')
- {
- {
- if (c1 != 1)
- return (free (compile_stack.stack), REG_ECOLLATE);
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- (b[((unsigned char) (str[0])) / 8] |= 1 << (((unsigned char) str[0]) % 8));
- range_start = ((const unsigned char *) str)[0];
- }
- had_char_class = 0;
- }
- else
- {
- c1++;
- while (c1--)
- p--;
- (b[((unsigned char) ('[')) / 8] |= 1 << (((unsigned char) '[') % 8));
- (b[((unsigned char) ('.')) / 8] |= 1 << (((unsigned char) '.') % 8));
- range_start = '.';
- had_char_class = 0;
- }
- }
- else
- {
- had_char_class = 0;
- (b[((unsigned char) (c)) / 8] |= 1 << (((unsigned char) c) % 8));
- range_start = c;
- }
- }
- while ((int) b[-1] > 0 && b[b[-1] - 1] == 0)
- b[-1]--;
- b += b[-1];
- }
- break;
- case '(':
- if (syntax & (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto handle_open;
- else
- goto normal_char;
- case ')':
- if (syntax & (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto handle_close;
- else
- goto normal_char;
- case '\n':
- if (syntax & (((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto handle_alt;
- else
- goto normal_char;
- case '|':
- if (syntax & (((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto handle_alt;
- else
- goto normal_char;
- case '{':
- if (syntax & (((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) && syntax & ((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto handle_interval;
- else
- goto normal_char;
- case '\\':
- if (p == pend) return (free (compile_stack.stack), REG_EESCAPE);
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; } while (0);
- switch (c)
- {
- case '(':
- if (syntax & (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_backslash;
- handle_open:
- bufp->re_nsub++;
- regnum++;
- if ((compile_stack.avail == compile_stack.size))
- {
- ((compile_stack.stack) = (compile_stack_elt_t *) realloc (compile_stack.stack, (compile_stack.size << 1) * sizeof (compile_stack_elt_t)));
- if (compile_stack.stack == ((void *)0)) return REG_ESPACE;
- compile_stack.size <<= 1;
- }
- (compile_stack.stack[compile_stack.avail]).begalt_offset = begalt - bufp->buffer;
- (compile_stack.stack[compile_stack.avail]).fixup_alt_jump
- = fixup_alt_jump ? fixup_alt_jump - bufp->buffer + 1 : 0;
- (compile_stack.stack[compile_stack.avail]).laststart_offset = b - bufp->buffer;
- (compile_stack.stack[compile_stack.avail]).regnum = regnum;
- if (regnum <= 255)
- {
- (compile_stack.stack[compile_stack.avail]).inner_group_offset = b
- - bufp->buffer + 2;
- do { while ((unsigned long) (b - bufp->buffer + (3)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (start_memory); *b++ = (unsigned char) (regnum); *b++ = (unsigned char) (0); } while (0);
- }
- compile_stack.avail++;
- fixup_alt_jump = 0;
- laststart = 0;
- begalt = b;
- pending_exact = 0;
- break;
- case ')':
- if (syntax & (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)) goto normal_backslash;
- if ((compile_stack.avail == 0))
- {
- if (syntax & (((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_backslash;
- else
- return (free (compile_stack.stack), REG_ERPAREN);
- }
- handle_close:
- if (fixup_alt_jump)
- {
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (push_dummy_failure); } while (0);
- byte_store_op1 (jump_past_alt, fixup_alt_jump, (int) ((b - 1) - (fixup_alt_jump) - (1 + 2)));
- }
- if ((compile_stack.avail == 0))
- {
- if (syntax & (((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- else
- return (free (compile_stack.stack), REG_ERPAREN);
- }
- ;
- {
- regnum_t this_group_regnum;
- compile_stack.avail--;
- begalt = bufp->buffer + (compile_stack.stack[compile_stack.avail]).begalt_offset;
- fixup_alt_jump
- = (compile_stack.stack[compile_stack.avail]).fixup_alt_jump
- ? bufp->buffer + (compile_stack.stack[compile_stack.avail]).fixup_alt_jump - 1
- : 0;
- laststart = bufp->buffer + (compile_stack.stack[compile_stack.avail]).laststart_offset;
- this_group_regnum = (compile_stack.stack[compile_stack.avail]).regnum;
- pending_exact = 0;
- if (this_group_regnum <= 255)
- {
- unsigned char *inner_group_loc
- = bufp->buffer + (compile_stack.stack[compile_stack.avail]).inner_group_offset;
- *inner_group_loc = regnum - this_group_regnum;
- do { while ((unsigned long) (b - bufp->buffer + (3)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (stop_memory); *b++ = (unsigned char) (this_group_regnum); *b++ = (unsigned char) (regnum - this_group_regnum); } while (0);
- }
- }
- break;
- case '|':
- if (syntax & ((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) || syntax & (((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_backslash;
- handle_alt:
- if (syntax & ((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- while ((unsigned long) (b - bufp->buffer + (1 + 2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- byte_insert_op1 (on_failure_jump, begalt, (int) ((b + 2 + 2 * 2) - (begalt) - (1 + 2)), b);
- pending_exact = 0;
- b += 1 + 2;
- if (fixup_alt_jump)
- byte_store_op1 (jump_past_alt, fixup_alt_jump, (int) ((b) - (fixup_alt_jump) - (1 + 2)));
- fixup_alt_jump = b;
- while ((unsigned long) (b - bufp->buffer + (1 + 2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- b += 1 + 2;
- laststart = 0;
- begalt = b;
- break;
- case '{':
- if (!(syntax & (((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- || (syntax & ((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- goto normal_backslash;
- handle_interval:
- {
- int lower_bound = -1, upper_bound = -1;
- const char *beg_interval = p;
- if (p == pend)
- goto invalid_interval;
- { while (p != pend) { do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0); if (c < '0' || c > '9') break; if (lower_bound <= (0x7fff)) { if (lower_bound < 0) lower_bound = 0; lower_bound = lower_bound * 10 + c - '0'; } } };
- if (c == ',')
- {
- { while (p != pend) { do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0); if (c < '0' || c > '9') break; if (upper_bound <= (0x7fff)) { if (upper_bound < 0) upper_bound = 0; upper_bound = upper_bound * 10 + c - '0'; } } };
- if (upper_bound < 0)
- upper_bound = (0x7fff);
- }
- else
- upper_bound = lower_bound;
- if (! (0 <= lower_bound && lower_bound <= upper_bound))
- goto invalid_interval;
- if (!(syntax & ((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- {
- if (c != '\\' || p == pend)
- goto invalid_interval;
- do {if (p == pend) return REG_EEND; c = (unsigned char) *p++; if (translate) c = (unsigned char) translate[c]; } while (0);
- }
- if (c != '}')
- goto invalid_interval;
- if (!laststart)
- {
- if (syntax & (((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1)
- && !(syntax & (((((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- return (free (compile_stack.stack), REG_BADRPT);
- else if (syntax & ((((((unsigned long int) 1) << 1) << 1) << 1) << 1))
- laststart = b;
- else
- goto unfetch_interval;
- }
- if ((0x7fff) < upper_bound)
- return (free (compile_stack.stack), REG_BADBR);
- if (upper_bound == 0)
- {
- while ((unsigned long) (b - bufp->buffer + (1 + 2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- byte_insert_op1 (jump, laststart, (int) ((b + 1 + 2) - (laststart) - (1 + 2)), b);
- b += 1 + 2;
- }
- else
- {
- unsigned nbytes = 2 + 4 * 2 +
- (upper_bound > 1) * (2 + 4 * 2);
- while ((unsigned long) (b - bufp->buffer + (nbytes)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0);
- byte_insert_op2 (succeed_n, laststart, (int) ((b + 1 + 2 * 2 + (upper_bound > 1) * (1 + 2 * 2)) - (laststart) - (1 + 2)), lower_bound, b);
- b += 1 + 2 * 2;
- byte_insert_op2 (set_number_at, laststart, 1
- + 2 * 2, lower_bound, b);
- b += 1 + 2 * 2;
- if (upper_bound > 1)
- {
- byte_store_op2 (jump_n, b, (int) ((laststart + 2 * 2 + 1) - (b) - (1 + 2)), upper_bound - 1);
- b += 1 + 2 * 2;
- byte_insert_op2 (set_number_at, laststart,
- b - laststart,
- upper_bound - 1, b);
- b += 1 + 2 * 2;
- }
- }
- pending_exact = 0;
- break;
- invalid_interval:
- if (!(syntax & (((((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- return (free (compile_stack.stack), p == pend ? REG_EBRACE : REG_BADBR);
- unfetch_interval:
- p = beg_interval;
- c = '{';
- if (syntax & ((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- else
- goto normal_backslash;
- }
- case 'w':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- laststart = b;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (wordchar); } while (0);
- break;
- case 'W':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- laststart = b;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (notwordchar); } while (0);
- break;
- case '<':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (wordbeg); } while (0);
- break;
- case '>':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (wordend); } while (0);
- break;
- case 'b':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (wordbound); } while (0);
- break;
- case 'B':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (notwordbound); } while (0);
- break;
- case '`':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (begbuf); } while (0);
- break;
- case '\'':
- if (syntax & (((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (endbuf); } while (0);
- break;
- case '1': case '2': case '3': case '4': case '5':
- case '6': case '7': case '8': case '9':
- if (syntax & ((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- goto normal_char;
- c1 = c - '0';
- if (c1 > regnum)
- return (free (compile_stack.stack), REG_ESUBREG);
- if (group_in_compile_stack (compile_stack, (regnum_t) c1))
- goto normal_char;
- laststart = b;
- do { while ((unsigned long) (b - bufp->buffer + (2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (duplicate); *b++ = (unsigned char) (c1); } while (0);
- break;
- case '+':
- case '?':
- if (syntax & (((unsigned long int) 1) << 1))
- goto handle_plus;
- else
- goto normal_backslash;
- default:
- normal_backslash:
- c = (translate ? (char) translate[(unsigned char) (c)] : (char) (c));
- goto normal_char;
- }
- break;
- default:
- normal_char:
- if (!pending_exact
- || pending_exact + *pending_exact + 1 != b
- || *pending_exact == (1 << 8) - 1
- || *p == '*' || *p == '^'
- || ((syntax & (((unsigned long int) 1) << 1))
- ? *p == '\\' && (p[1] == '+' || p[1] == '?')
- : (*p == '+' || *p == '?'))
- || ((syntax & (((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- && ((syntax & ((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- ? *p == '{'
- : (p[0] == '\\' && p[1] == '{'))))
- {
- laststart = b;
- do { while ((unsigned long) (b - bufp->buffer + (2)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (exactn); *b++ = (unsigned char) (0); } while (0);
- pending_exact = b - 1;
- }
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (c); } while (0);
- (*pending_exact)++;
- break;
- }
- }
- if (fixup_alt_jump)
- byte_store_op1 (jump_past_alt, fixup_alt_jump, (int) ((b) - (fixup_alt_jump) - (1 + 2)));
- if (!(compile_stack.avail == 0))
- return (free (compile_stack.stack), REG_EPAREN);
- if (syntax & ((((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1))
- do { while ((unsigned long) (b - bufp->buffer + (1)) > bufp->allocated) do { unsigned char *old_buffer = bufp->buffer; if (bufp->allocated == (1L << 16)) return REG_ESIZE; bufp->allocated <<= 1; if (bufp->allocated > (1L << 16)) bufp->allocated = (1L << 16); bufp->buffer = (unsigned char *) realloc ((bufp->buffer), (bufp->allocated)); if (bufp->buffer == ((void *)0)) return REG_ESPACE; if (old_buffer != bufp->buffer) { int incr = bufp->buffer - old_buffer; (b) += incr; (begalt) += incr; if (fixup_alt_jump) (fixup_alt_jump) += incr; if (laststart) (laststart) += incr; if (pending_exact) (pending_exact) += incr; } } while (0); *b++ = (unsigned char) (succeed); } while (0);
- free (compile_stack.stack);
- bufp->used = b - bufp->buffer;
- return REG_NOERROR;
-}
-static void
-byte_store_op1 (re_opcode_t op, unsigned char *loc, int arg)
-{
- *loc = (unsigned char) op;
- do { (loc + 1)[0] = (arg) & 0377; (loc + 1)[1] = (arg) >> 8; } while (0);
-}
-static void
-byte_store_op2 (re_opcode_t op, unsigned char *loc, int arg1, int arg2)
-{
- *loc = (unsigned char) op;
- do { (loc + 1)[0] = (arg1) & 0377; (loc + 1)[1] = (arg1) >> 8; } while (0);
- do { (loc + 1 + 2)[0] = (arg2) & 0377; (loc + 1 + 2)[1] = (arg2) >> 8; } while (0);
-}
-static void
-byte_insert_op1 (re_opcode_t op, unsigned char *loc, int arg, unsigned char *end)
-{
- register unsigned char *pfrom = end;
- register unsigned char *pto = end + 1 + 2;
- while (pfrom != loc)
- *--pto = *--pfrom;
- byte_store_op1 (op, loc, arg);
-}
-static void
-byte_insert_op2 (re_opcode_t op, unsigned char *loc, int arg1,
- int arg2, unsigned char *end)
-{
- register unsigned char *pfrom = end;
- register unsigned char *pto = end + 1 + 2 * 2;
- while (pfrom != loc)
- *--pto = *--pfrom;
- byte_store_op2 (op, loc, arg1, arg2);
-}
-static boolean
-byte_at_begline_loc_p (const char *pattern, const char *p,
- reg_syntax_t syntax)
-{
- const char *prev = p - 2;
- boolean prev_prev_backslash = prev > pattern && prev[-1] == '\\';
- return
- (*prev == '(' && (syntax & (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) || prev_prev_backslash))
- || (*prev == '|' && (syntax & (((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) || prev_prev_backslash));
-}
-static boolean
-byte_at_endline_loc_p (const char *p, const char *pend,
- reg_syntax_t syntax)
-{
- const char *next = p;
- boolean next_backslash = *next == '\\';
- const char *next_next = p + 1 < pend ? p + 1 : 0;
- return
- (syntax & (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) ? *next == ')'
- : next_backslash && next_next && *next_next == ')')
- || (syntax & (((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) ? *next == '|'
- : next_backslash && next_next && *next_next == '|');
-}
-static reg_errcode_t
-byte_compile_range (unsigned int range_start_char, const char **p_ptr,
- const char *pend, char * translate,
- reg_syntax_t syntax, unsigned char *b)
-{
- unsigned this_char;
- const char *p = *p_ptr;
- reg_errcode_t ret;
- unsigned end_char;
- if (p == pend)
- return REG_ERANGE;
- (*p_ptr)++;
- ret = syntax & ((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) ? REG_ERANGE : REG_NOERROR;
- range_start_char = (translate ? (char) translate[(unsigned char) (range_start_char)] : (char) (range_start_char));
- end_char = ((unsigned)(translate ? (char) translate[(unsigned char) (p[0])] : (char) (p[0])) & ((1 << 8) - 1));
- for (this_char = range_start_char; this_char <= end_char; ++this_char)
- {
- (b[((unsigned char) ((translate ? (char) translate[(unsigned char) (this_char)] : (char) (this_char)))) / 8] |= 1 << (((unsigned char) (translate ? (char) translate[(unsigned char) (this_char)] : (char) (this_char))) % 8));
- ret = REG_NOERROR;
- }
- return ret;
-}
-static int
-byte_re_compile_fastmap (struct re_pattern_buffer *bufp)
-{
- int j, k;
- byte_fail_stack_type fail_stack;
- char *destination;
- register char *fastmap = bufp->fastmap;
- unsigned char *pattern = bufp->buffer;
- register unsigned char *pend = pattern + bufp->used;
- unsigned char *p = pattern;
- boolean path_can_be_null = 1;
- boolean succeed_n_p = 0;
- ;
- do { fail_stack.stack = (byte_fail_stack_elt_t *) __builtin_alloca (5 * sizeof (byte_fail_stack_elt_t)); if (fail_stack.stack == ((void *)0)) return -2; fail_stack.size = 5; fail_stack.avail = 0; } while (0);
- (memset (fastmap, '\0', 1 << 8), (fastmap));
- bufp->fastmap_accurate = 1;
- bufp->can_be_null = 0;
- while (1)
- {
- if (p == pend || *p == (unsigned char) succeed)
- {
- if (!(fail_stack.avail == 0))
- {
- bufp->can_be_null |= path_can_be_null;
- path_can_be_null = 1;
- p = fail_stack.stack[--fail_stack.avail].pointer;
- continue;
- }
- else
- break;
- }
- ;
- switch (((re_opcode_t) *p++))
- {
- case duplicate:
- bufp->can_be_null = 1;
- goto done;
- case exactn:
- fastmap[p[1]] = 1;
- break;
- case charset:
- for (j = *p++ * 8 - 1; j >= 0; j--)
- if (p[j / 8] & (1 << (j % 8)))
- fastmap[j] = 1;
- break;
- case charset_not:
- for (j = *p * 8; j < (1 << 8); j++)
- fastmap[j] = 1;
- for (j = *p++ * 8 - 1; j >= 0; j--)
- if (!(p[j / 8] & (1 << (j % 8))))
- fastmap[j] = 1;
- break;
- case wordchar:
- for (j = 0; j < (1 << 8); j++)
- if (re_syntax_table[(unsigned char) (j)] == 1)
- fastmap[j] = 1;
- break;
- case notwordchar:
- for (j = 0; j < (1 << 8); j++)
- if (re_syntax_table[(unsigned char) (j)] != 1)
- fastmap[j] = 1;
- break;
- case anychar:
- {
- int fastmap_newline = fastmap['\n'];
- for (j = 0; j < (1 << 8); j++)
- fastmap[j] = 1;
- if (!(bufp->syntax & ((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1)))
- fastmap['\n'] = fastmap_newline;
- else if (bufp->can_be_null)
- goto done;
- break;
- }
- case no_op:
- case begline:
- case endline:
- case begbuf:
- case endbuf:
- case wordbound:
- case notwordbound:
- case wordbeg:
- case wordend:
- case push_dummy_failure:
- continue;
- case jump_n:
- case pop_failure_jump:
- case maybe_pop_jump:
- case jump:
- case jump_past_alt:
- case dummy_failure_jump:
- do { do { (j) = *(p) & 0377; (j) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- p += j;
- if (j > 0)
- continue;
- if ((re_opcode_t) *p != on_failure_jump
- && (re_opcode_t) *p != succeed_n)
- continue;
- p++;
- do { do { (j) = *(p) & 0377; (j) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- p += j;
- if (!(fail_stack.avail == 0)
- && fail_stack.stack[fail_stack.avail - 1].pointer == p)
- fail_stack.avail--;
- continue;
- case on_failure_jump:
- case on_failure_keep_string_jump:
- handle_on_failure_jump:
- do { do { (j) = *(p) & 0377; (j) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- if (p + j < pend)
- {
- if (!(((fail_stack.avail == fail_stack.size) && !((fail_stack).size > (unsigned) (xre_max_failures * (5 * 3 + 4)) ? 0 : ((fail_stack).stack = (byte_fail_stack_elt_t *) (destination = (char *) __builtin_alloca (((fail_stack).size << 1) * sizeof (byte_fail_stack_elt_t)), memcpy (destination, (fail_stack).stack, (fail_stack).size * sizeof (byte_fail_stack_elt_t))), (fail_stack).stack == ((void *)0) ? 0 : ((fail_stack).size <<= 1, 1)))) ? 0 : ((fail_stack).stack[(fail_stack).avail++].pointer = p + j, 1)))
- {
- ;
- return -2;
- }
- }
- else
- bufp->can_be_null = 1;
- if (succeed_n_p)
- {
- do { do { (k) = *(p) & 0377; (k) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- succeed_n_p = 0;
- }
- continue;
- case succeed_n:
- p += 2;
- do { do { (k) = *(p) & 0377; (k) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- if (k == 0)
- {
- p -= 2 * 2;
- succeed_n_p = 1;
- goto handle_on_failure_jump;
- }
- continue;
- case set_number_at:
- p += 2 * 2;
- continue;
- case start_memory:
- case stop_memory:
- p += 2;
- continue;
- default:
- abort ();
- }
- path_can_be_null = 0;
- p = pend;
- }
- bufp->can_be_null |= path_can_be_null;
- done:
- ;
- return 0;
-}
-static int
-byte_re_search_2 (struct re_pattern_buffer *bufp, const char *string1,
- int size1, const char *string2, int size2,
- int startpos, int range,
- struct re_registers *regs, int stop)
-{
- int val;
- register char *fastmap = bufp->fastmap;
- register char * translate = bufp->translate;
- int total_size = size1 + size2;
- int endpos = startpos + range;
- if (startpos < 0 || startpos > total_size)
- return -1;
- if (endpos < 0)
- range = 0 - startpos;
- else if (endpos > total_size)
- range = total_size - startpos;
- if (bufp->used > 0 && range > 0
- && ((re_opcode_t) bufp->buffer[0] == begbuf
- || ((re_opcode_t) bufp->buffer[0] == begline
- && !bufp->newline_anchor)))
- {
- if (startpos > 0)
- return -1;
- else
- range = 1;
- }
- if (fastmap && !bufp->fastmap_accurate)
- if (xre_compile_fastmap (bufp) == -2)
- return -2;
- for (;;)
- {
- if (fastmap && startpos < total_size && !bufp->can_be_null)
- {
- if (range > 0)
- {
- register const char *d;
- register int lim = 0;
- int irange = range;
- if (startpos < size1 && startpos + range >= size1)
- lim = range - (size1 - startpos);
- d = (startpos >= size1 ? string2 - size1 : string1) + startpos;
- if (translate)
- while (range > lim
- && !fastmap[(unsigned char)
- translate[(unsigned char) *d++]])
- range--;
- else
- while (range > lim && !fastmap[(unsigned char) *d++])
- range--;
- startpos += irange - range;
- }
- else
- {
- register char c = (size1 == 0 || startpos >= size1
- ? string2[startpos - size1]
- : string1[startpos]);
- if (!fastmap[(unsigned char) (translate ? (char) translate[(unsigned char) (c)] : (char) (c))])
- goto advance;
- }
- }
- if (range >= 0 && startpos == total_size && fastmap
- && !bufp->can_be_null)
- {
- return -1;
- }
- val = byte_re_match_2_internal (bufp, string1, size1, string2,
- size2, startpos, regs, stop);
- if (val >= 0)
- {
- return startpos;
- }
- if (val == -2)
- {
- return -2;
- }
- advance:
- if (!range)
- break;
- else if (range > 0)
- {
- range--;
- startpos++;
- }
- else
- {
- range++;
- startpos--;
- }
- }
- return -1;
-}
-static boolean byte_group_match_null_string_p (unsigned char **p,
- unsigned char *end,
- byte_register_info_type *reg_info);
-static boolean byte_alt_match_null_string_p (unsigned char *p,
- unsigned char *end,
- byte_register_info_type *reg_info);
-static boolean byte_common_op_match_null_string_p (unsigned char **p,
- unsigned char *end,
- byte_register_info_type *reg_info);
-static int byte_bcmp_translate (const char *s1, const char *s2,
- int len, char *translate);
-static int
-byte_re_match_2_internal (struct re_pattern_buffer *bufp,
- const char *string1, int size1,
- const char *string2, int size2,
- int pos,
- struct re_registers *regs, int stop)
-{
- int mcnt;
- unsigned char *p1;
- const char *end1, *end2;
- const char *end_match_1, *end_match_2;
- const char *d, *dend;
- unsigned char *p = bufp->buffer;
- register unsigned char *pend = p + bufp->used;
- unsigned char *just_past_start_mem = 0;
- char * translate = bufp->translate;
- byte_fail_stack_type fail_stack;
- size_t num_regs = bufp->re_nsub + 1;
- active_reg_t lowest_active_reg = ((1 << 8) + 1);
- active_reg_t highest_active_reg = (1 << 8);
- const char **regstart, **regend;
- const char **old_regstart, **old_regend;
- byte_register_info_type *reg_info;
- unsigned best_regs_set = 0;
- const char **best_regstart, **best_regend;
- const char *match_end = ((void *)0);
- int set_regs_matched_done = 0;
- const char **reg_dummy;
- byte_register_info_type *reg_info_dummy;
- ;
- do { fail_stack.stack = (byte_fail_stack_elt_t *) __builtin_alloca (5 * sizeof (byte_fail_stack_elt_t)); if (fail_stack.stack == ((void *)0)) return -2; fail_stack.size = 5; fail_stack.avail = 0; } while (0);
- if (bufp->re_nsub)
- {
- regstart = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- regend = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- old_regstart = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- old_regend = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- best_regstart = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- best_regend = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- reg_info = ((byte_register_info_type *) __builtin_alloca ((num_regs) * sizeof (byte_register_info_type)));
- reg_dummy = ((const char * *) __builtin_alloca ((num_regs) * sizeof (const char *)));
- reg_info_dummy = ((byte_register_info_type *) __builtin_alloca ((num_regs) * sizeof (byte_register_info_type)));
- if (!(regstart && regend && old_regstart && old_regend && reg_info
- && best_regstart && best_regend && reg_dummy && reg_info_dummy))
- {
- do { ; if (regstart) ((void)0); regstart = ((void *)0); if (regend) ((void)0); regend = ((void *)0); if (old_regstart) ((void)0); old_regstart = ((void *)0); if (old_regend) ((void)0); old_regend = ((void *)0); if (best_regstart) ((void)0); best_regstart = ((void *)0); if (best_regend) ((void)0); best_regend = ((void *)0); if (reg_info) ((void)0); reg_info = ((void *)0); if (reg_dummy) ((void)0); reg_dummy = ((void *)0); if (reg_info_dummy) ((void)0); reg_info_dummy = ((void *)0); } while (0);
- return -2;
- }
- }
- else
- {
- regstart = regend = old_regstart = old_regend = best_regstart
- = best_regend = reg_dummy = ((void *)0);
- reg_info = reg_info_dummy = (byte_register_info_type *) ((void *)0);
- }
- if (pos < 0 || pos > size1 + size2)
- {
- do { ; if (regstart) ((void)0); regstart = ((void *)0); if (regend) ((void)0); regend = ((void *)0); if (old_regstart) ((void)0); old_regstart = ((void *)0); if (old_regend) ((void)0); old_regend = ((void *)0); if (best_regstart) ((void)0); best_regstart = ((void *)0); if (best_regend) ((void)0); best_regend = ((void *)0); if (reg_info) ((void)0); reg_info = ((void *)0); if (reg_dummy) ((void)0); reg_dummy = ((void *)0); if (reg_info_dummy) ((void)0); reg_info_dummy = ((void *)0); } while (0);
- return -1;
- }
- for (mcnt = 1; (unsigned) mcnt < num_regs; mcnt++)
- {
- regstart[mcnt] = regend[mcnt]
- = old_regstart[mcnt] = old_regend[mcnt] = (&byte_reg_unset_dummy);
- ((reg_info[mcnt]).bits.match_null_string_p) = 3;
- ((reg_info[mcnt]).bits.is_active) = 0;
- ((reg_info[mcnt]).bits.matched_something) = 0;
- ((reg_info[mcnt]).bits.ever_matched_something) = 0;
- }
- if (size2 == 0 && string1 != ((void *)0))
- {
- string2 = string1;
- size2 = size1;
- string1 = 0;
- size1 = 0;
- }
- end1 = string1 + size1;
- end2 = string2 + size2;
- if (stop <= size1)
- {
- end_match_1 = string1 + stop;
- end_match_2 = string2;
- }
- else
- {
- end_match_1 = end1;
- end_match_2 = string2 + stop - size1;
- }
- if (size1 > 0 && pos <= size1)
- {
- d = string1 + pos;
- dend = end_match_1;
- }
- else
- {
- d = string2 + pos - size1;
- dend = end_match_2;
- }
- ;
- ;
- ;
- ;
- ;
- for (;;)
- {
- ;
- if (p == pend)
- {
- ;
- if (d != end_match_2)
- {
- boolean same_str_p = ((size1 && string1 <= (match_end) && (match_end) <= string1 + size1)
- == (dend == end_match_1));
- boolean best_match_p;
- if (same_str_p)
- best_match_p = d > match_end;
- else
- best_match_p = !(dend == end_match_1);
- ;
- if (!(fail_stack.avail == 0))
- {
- if (!best_regs_set || best_match_p)
- {
- best_regs_set = 1;
- match_end = d;
- ;
- for (mcnt = 1; (unsigned) mcnt < num_regs; mcnt++)
- {
- best_regstart[mcnt] = regstart[mcnt];
- best_regend[mcnt] = regend[mcnt];
- }
- }
- goto fail;
- }
- else if (best_regs_set && !best_match_p)
- {
- restore_best_regs:
- ;
- d = match_end;
- dend = ((d >= string1 && d <= end1)
- ? end_match_1 : end_match_2);
- for (mcnt = 1; (unsigned) mcnt < num_regs; mcnt++)
- {
- regstart[mcnt] = best_regstart[mcnt];
- regend[mcnt] = best_regend[mcnt];
- }
- }
- }
- succeed_label:
- ;
- if (regs && !bufp->no_sub)
- {
- if (bufp->regs_allocated == 0)
- {
- regs->num_regs = ((30) > (num_regs + 1) ? (30) : (num_regs + 1));
- regs->start = ((regoff_t *) malloc ((regs->num_regs) * sizeof (regoff_t)));
- regs->end = ((regoff_t *) malloc ((regs->num_regs) * sizeof (regoff_t)));
- if (regs->start == ((void *)0) || regs->end == ((void *)0))
- {
- do { ; if (regstart) ((void)0); regstart = ((void *)0); if (regend) ((void)0); regend = ((void *)0); if (old_regstart) ((void)0); old_regstart = ((void *)0); if (old_regend) ((void)0); old_regend = ((void *)0); if (best_regstart) ((void)0); best_regstart = ((void *)0); if (best_regend) ((void)0); best_regend = ((void *)0); if (reg_info) ((void)0); reg_info = ((void *)0); if (reg_dummy) ((void)0); reg_dummy = ((void *)0); if (reg_info_dummy) ((void)0); reg_info_dummy = ((void *)0); } while (0);
- return -2;
- }
- bufp->regs_allocated = 1;
- }
- else if (bufp->regs_allocated == 1)
- {
- if (regs->num_regs < num_regs + 1)
- {
- regs->num_regs = num_regs + 1;
- ((regs->start) = (regoff_t *) realloc (regs->start, (regs->num_regs) * sizeof (regoff_t)));
- ((regs->end) = (regoff_t *) realloc (regs->end, (regs->num_regs) * sizeof (regoff_t)));
- if (regs->start == ((void *)0) || regs->end == ((void *)0))
- {
- do { ; if (regstart) ((void)0); regstart = ((void *)0); if (regend) ((void)0); regend = ((void *)0); if (old_regstart) ((void)0); old_regstart = ((void *)0); if (old_regend) ((void)0); old_regend = ((void *)0); if (best_regstart) ((void)0); best_regstart = ((void *)0); if (best_regend) ((void)0); best_regend = ((void *)0); if (reg_info) ((void)0); reg_info = ((void *)0); if (reg_dummy) ((void)0); reg_dummy = ((void *)0); if (reg_info_dummy) ((void)0); reg_info_dummy = ((void *)0); } while (0);
- return -2;
- }
- }
- }
- else
- {
- ;
- }
- if (regs->num_regs > 0)
- {
- regs->start[0] = pos;
- regs->end[0] = ((dend == end_match_1)
- ? ((regoff_t) (d - string1))
- : ((regoff_t) (d - string2 + size1)));
- }
- for (mcnt = 1; (unsigned) mcnt < ((num_regs) < (regs->num_regs) ? (num_regs) : (regs->num_regs));
- mcnt++)
- {
- if (((regstart[mcnt]) == (&byte_reg_unset_dummy)) || ((regend[mcnt]) == (&byte_reg_unset_dummy)))
- regs->start[mcnt] = regs->end[mcnt] = -1;
- else
- {
- regs->start[mcnt]
- = (regoff_t) ((size1 && string1 <= (regstart[mcnt]) && (regstart[mcnt]) <= string1 + size1) ? ((regoff_t) ((regstart[mcnt]) - string1)) : ((regoff_t) ((regstart[mcnt]) - string2 + size1)));
- regs->end[mcnt]
- = (regoff_t) ((size1 && string1 <= (regend[mcnt]) && (regend[mcnt]) <= string1 + size1) ? ((regoff_t) ((regend[mcnt]) - string1)) : ((regoff_t) ((regend[mcnt]) - string2 + size1)));
- }
- }
- for (mcnt = num_regs; (unsigned) mcnt < regs->num_regs; mcnt++)
- regs->start[mcnt] = regs->end[mcnt] = -1;
- }
- ;
- ;
- mcnt = d - pos - ((dend == end_match_1)
- ? string1
- : string2 - size1);
- ;
- do { ; if (regstart) ((void)0); regstart = ((void *)0); if (regend) ((void)0); regend = ((void *)0); if (old_regstart) ((void)0); old_regstart = ((void *)0); if (old_regend) ((void)0); old_regend = ((void *)0); if (best_regstart) ((void)0); best_regstart = ((void *)0); if (best_regend) ((void)0); best_regend = ((void *)0); if (reg_info) ((void)0); reg_info = ((void *)0); if (reg_dummy) ((void)0); reg_dummy = ((void *)0); if (reg_info_dummy) ((void)0); reg_info_dummy = ((void *)0); } while (0);
- return mcnt;
- }
- switch (((re_opcode_t) *p++))
- {
- case no_op:
- ;
- break;
- case succeed:
- ;
- goto succeed_label;
- case exactn:
- mcnt = *p++;
- ;
- if (translate)
- {
- do
- {
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- if ((unsigned char) translate[(unsigned char) *d++]
- != (unsigned char) *p++)
- goto fail;
- }
- while (--mcnt);
- }
- else
- {
- do
- {
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- if (*d++ != (char) *p++) goto fail;
- }
- while (--mcnt);
- }
- do { if (!set_regs_matched_done) { active_reg_t r; set_regs_matched_done = 1; for (r = lowest_active_reg; r <= highest_active_reg; r++) { ((reg_info[r]).bits.matched_something) = ((reg_info[r]).bits.ever_matched_something) = 1; } } } while (0);
- break;
- case anychar:
- ;
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- if ((!(bufp->syntax & ((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1)) && (translate ? (char) translate[(unsigned char) (*d)] : (char) (*d)) == '\n')
- || (bufp->syntax & (((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) && (translate ? (char) translate[(unsigned char) (*d)] : (char) (*d)) == '\000'))
- goto fail;
- do { if (!set_regs_matched_done) { active_reg_t r; set_regs_matched_done = 1; for (r = lowest_active_reg; r <= highest_active_reg; r++) { ((reg_info[r]).bits.matched_something) = ((reg_info[r]).bits.ever_matched_something) = 1; } } } while (0);
- ;
- d++;
- break;
- case charset:
- case charset_not:
- {
- register unsigned char c;
- boolean negate = (re_opcode_t) *(p - 1) == charset_not;
- ;
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- c = (translate ? (char) translate[(unsigned char) (*d)] : (char) (*d));
- if (c < (unsigned) (*p * 8)
- && p[1 + c / 8] & (1 << (c % 8)))
- negate = !negate;
- p += 1 + *p;
- if (!negate) goto fail;
- do { if (!set_regs_matched_done) { active_reg_t r; set_regs_matched_done = 1; for (r = lowest_active_reg; r <= highest_active_reg; r++) { ((reg_info[r]).bits.matched_something) = ((reg_info[r]).bits.ever_matched_something) = 1; } } } while (0);
- d++;
- break;
- }
- case start_memory:
- ;
- p1 = p;
- if (((reg_info[*p]).bits.match_null_string_p) == 3)
- ((reg_info[*p]).bits.match_null_string_p)
- = byte_group_match_null_string_p (&p1, pend, reg_info);
- old_regstart[*p] = ((reg_info[*p]).bits.match_null_string_p)
- ? ((regstart[*p]) == (&byte_reg_unset_dummy)) ? d : regstart[*p]
- : regstart[*p];
- ;
- regstart[*p] = d;
- ;
- ((reg_info[*p]).bits.is_active) = 1;
- ((reg_info[*p]).bits.matched_something) = 0;
- set_regs_matched_done = 0;
- highest_active_reg = *p;
- if (lowest_active_reg == ((1 << 8) + 1))
- lowest_active_reg = *p;
- p += 2;
- just_past_start_mem = p;
- break;
- case stop_memory:
- ;
- old_regend[*p] = ((reg_info[*p]).bits.match_null_string_p)
- ? ((regend[*p]) == (&byte_reg_unset_dummy)) ? d : regend[*p]
- : regend[*p];
- ;
- regend[*p] = d;
- ;
- ((reg_info[*p]).bits.is_active) = 0;
- set_regs_matched_done = 0;
- if (lowest_active_reg == highest_active_reg)
- {
- lowest_active_reg = ((1 << 8) + 1);
- highest_active_reg = (1 << 8);
- }
- else
- {
- unsigned char r = *p - 1;
- while (r > 0 && !((reg_info[r]).bits.is_active))
- r--;
- if (r == 0)
- {
- lowest_active_reg = ((1 << 8) + 1);
- highest_active_reg = (1 << 8);
- }
- else
- highest_active_reg = r;
- }
- if ((!((reg_info[*p]).bits.matched_something)
- || just_past_start_mem == p - 1)
- && (p + 2) < pend)
- {
- boolean is_a_jump_n = 0;
- p1 = p + 2;
- mcnt = 0;
- switch ((re_opcode_t) *p1++)
- {
- case jump_n:
- is_a_jump_n = 1;
- case pop_failure_jump:
- case maybe_pop_jump:
- case jump:
- case dummy_failure_jump:
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- if (is_a_jump_n)
- p1 += 2;
- break;
- default:
- ;
- }
- p1 += mcnt;
- if (mcnt < 0 && (re_opcode_t) *p1 == on_failure_jump
- && (re_opcode_t) p1[1+2] == start_memory
- && p1[2+2] == *p)
- {
- if (((reg_info[*p]).bits.ever_matched_something))
- {
- unsigned r;
- ((reg_info[*p]).bits.ever_matched_something) = 0;
- for (r = *p; r < (unsigned) *p + (unsigned) *(p + 1);
- r++)
- {
- regstart[r] = old_regstart[r];
- if (old_regend[r] >= regstart[r])
- regend[r] = old_regend[r];
- }
- }
- p1++;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- do { char *destination; active_reg_t this_reg; ; ; ; ; ; ; ; while (((fail_stack).size - (fail_stack).avail) < (((0 ? 0 : highest_active_reg - lowest_active_reg + 1) * 3) + 4)) { if (!((fail_stack).size > (unsigned) (xre_max_failures * (5 * 3 + 4)) ? 0 : ((fail_stack).stack = (byte_fail_stack_elt_t *) (destination = (char *) __builtin_alloca (((fail_stack).size << 1) * sizeof (byte_fail_stack_elt_t)), memcpy (destination, (fail_stack).stack, (fail_stack).size * sizeof (byte_fail_stack_elt_t))), (fail_stack).stack == ((void *)0) ? 0 : ((fail_stack).size <<= 1, 1)))) return -2; ; ; } ; if (1) for (this_reg = lowest_active_reg; this_reg <= highest_active_reg; this_reg++) { ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regstart[this_reg]); ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regend[this_reg]); ; ; ; ; ; ; fail_stack.stack[fail_stack.avail++] = (reg_info[this_reg].word); } ; fail_stack.stack[fail_stack.a!
vail++].i
nteger = (lowest_active_reg); ; fail_stack.stack[fail_stack.avail++].integer = (highest_active_reg); ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (p1 + mcnt); ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (d); ; ; } while (0);
- goto fail;
- }
- }
- p += 2;
- break;
- case duplicate:
- {
- register const char *d2, *dend2;
- int regno = *p++;
- ;
- if (((regstart[regno]) == (&byte_reg_unset_dummy)) || ((regend[regno]) == (&byte_reg_unset_dummy)))
- goto fail;
- d2 = regstart[regno];
- dend2 = (((size1 && string1 <= (regstart[regno]) && (regstart[regno]) <= string1 + size1)
- == (size1 && string1 <= (regend[regno]) && (regend[regno]) <= string1 + size1))
- ? regend[regno] : end_match_1);
- for (;;)
- {
- while (d2 == dend2)
- {
- if (dend2 == end_match_2) break;
- if (dend2 == regend[regno]) break;
- d2 = string2;
- dend2 = regend[regno];
- }
- if (d2 == dend2) break;
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- mcnt = dend - d;
- if (mcnt > dend2 - d2)
- mcnt = dend2 - d2;
- if (translate
- ? byte_bcmp_translate (d, d2, mcnt, translate)
- : memcmp (d, d2, mcnt*sizeof(unsigned char)))
- goto fail;
- d += mcnt, d2 += mcnt;
- do { if (!set_regs_matched_done) { active_reg_t r; set_regs_matched_done = 1; for (r = lowest_active_reg; r <= highest_active_reg; r++) { ((reg_info[r]).bits.matched_something) = ((reg_info[r]).bits.ever_matched_something) = 1; } } } while (0);
- }
- }
- break;
- case begline:
- ;
- if (((d) == (size1 ? string1 : string2) || !size2))
- {
- if (!bufp->not_bol) break;
- }
- else if (d[-1] == '\n' && bufp->newline_anchor)
- {
- break;
- }
- goto fail;
- case endline:
- ;
- if (((d) == end2))
- {
- if (!bufp->not_eol) break;
- }
- else if ((d == end1 ? *string2 : *d) == '\n'
- && bufp->newline_anchor)
- {
- break;
- }
- goto fail;
- case begbuf:
- ;
- if (((d) == (size1 ? string1 : string2) || !size2))
- break;
- goto fail;
- case endbuf:
- ;
- if (((d) == end2))
- break;
- goto fail;
- case on_failure_keep_string_jump:
- ;
- do { do { (mcnt) = *(p) & 0377; (mcnt) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- ;
- do { char *destination; active_reg_t this_reg; ; ; ; ; ; ; ; while (((fail_stack).size - (fail_stack).avail) < (((0 ? 0 : highest_active_reg - lowest_active_reg + 1) * 3) + 4)) { if (!((fail_stack).size > (unsigned) (xre_max_failures * (5 * 3 + 4)) ? 0 : ((fail_stack).stack = (byte_fail_stack_elt_t *) (destination = (char *) __builtin_alloca (((fail_stack).size << 1) * sizeof (byte_fail_stack_elt_t)), memcpy (destination, (fail_stack).stack, (fail_stack).size * sizeof (byte_fail_stack_elt_t))), (fail_stack).stack == ((void *)0) ? 0 : ((fail_stack).size <<= 1, 1)))) return -2; ; ; } ; if (1) for (this_reg = lowest_active_reg; this_reg <= highest_active_reg; this_reg++) { ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regstart[this_reg]); ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regend[this_reg]); ; ; ; ; ; ; fail_stack.stack[fail_stack.avail++] = (reg_info[this_reg].word); } ; fail_stack.stack[fail_stack.avail++].!
integer =
(lowest_active_reg); ; fail_stack.stack[fail_stack.avail++].integer = (highest_active_reg); ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (p + mcnt); ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (((void *)0)); ; ; } while (0);
- break;
- case on_failure_jump:
- on_failure:
- ;
- do { do { (mcnt) = *(p) & 0377; (mcnt) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- ;
- p1 = p;
- while (p1 < pend && (re_opcode_t) *p1 == no_op)
- p1++;
- if (p1 < pend && (re_opcode_t) *p1 == start_memory)
- {
- highest_active_reg = *(p1 + 1) + *(p1 + 2);
- if (lowest_active_reg == ((1 << 8) + 1))
- lowest_active_reg = *(p1 + 1);
- }
- ;
- do { char *destination; active_reg_t this_reg; ; ; ; ; ; ; ; while (((fail_stack).size - (fail_stack).avail) < (((0 ? 0 : highest_active_reg - lowest_active_reg + 1) * 3) + 4)) { if (!((fail_stack).size > (unsigned) (xre_max_failures * (5 * 3 + 4)) ? 0 : ((fail_stack).stack = (byte_fail_stack_elt_t *) (destination = (char *) __builtin_alloca (((fail_stack).size << 1) * sizeof (byte_fail_stack_elt_t)), memcpy (destination, (fail_stack).stack, (fail_stack).size * sizeof (byte_fail_stack_elt_t))), (fail_stack).stack == ((void *)0) ? 0 : ((fail_stack).size <<= 1, 1)))) return -2; ; ; } ; if (1) for (this_reg = lowest_active_reg; this_reg <= highest_active_reg; this_reg++) { ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regstart[this_reg]); ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regend[this_reg]); ; ; ; ; ; ; fail_stack.stack[fail_stack.avail++] = (reg_info[this_reg].word); } ; fail_stack.stack[fail_stack.avail++].!
integer =
(lowest_active_reg); ; fail_stack.stack[fail_stack.avail++].integer = (highest_active_reg); ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (p + mcnt); ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (d); ; ; } while (0);
- break;
- case maybe_pop_jump:
- do { do { (mcnt) = *(p) & 0377; (mcnt) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- ;
- {
- register unsigned char *p2 = p;
- while (1)
- {
- if (p2 + 2 < pend
- && ((re_opcode_t) *p2 == stop_memory
- || (re_opcode_t) *p2 == start_memory))
- p2 += 3;
- else if (p2 + 2 + 2 * 2 < pend
- && (re_opcode_t) *p2 == dummy_failure_jump)
- p2 += 2 + 2 * 2;
- else
- break;
- }
- p1 = p + mcnt;
- if (p2 == pend)
- {
- p[-(1+2)] = (unsigned char)
- pop_failure_jump;
- ;
- }
- else if ((re_opcode_t) *p2 == exactn
- || (bufp->newline_anchor && (re_opcode_t) *p2 == endline))
- {
- register unsigned char c
- = *p2 == (unsigned char) endline ? '\n' : p2[2];
- if (((re_opcode_t) p1[1+2] == exactn
- ) && p1[3+2] != c)
- {
- p[-(1+2)] = (unsigned char)
- pop_failure_jump;
- ;
- }
- else if ((re_opcode_t) p1[3] == charset
- || (re_opcode_t) p1[3] == charset_not)
- {
- int negate = (re_opcode_t) p1[3] == charset_not;
- if (c < (unsigned) (p1[4] * 8)
- && p1[5 + c / 8] & (1 << (c % 8)))
- negate = !negate;
- if (!negate)
- {
- p[-3] = (unsigned char) pop_failure_jump;
- ;
- }
- }
- }
- else if ((re_opcode_t) *p2 == charset)
- {
- if ((re_opcode_t) p1[3] == exactn
- && ! ((int) p2[1] * 8 > (int) p1[5]
- && (p2[2 + p1[5] / 8]
- & (1 << (p1[5] % 8)))))
- {
- p[-3] = (unsigned char) pop_failure_jump;
- ;
- }
- else if ((re_opcode_t) p1[3] == charset_not)
- {
- int idx;
- for (idx = 0; idx < (int) p2[1]; idx++)
- if (! (p2[2 + idx] == 0
- || (idx < (int) p1[4]
- && ((p2[2 + idx] & ~ p1[5 + idx]) == 0))))
- break;
- if (idx == p2[1])
- {
- p[-3] = (unsigned char) pop_failure_jump;
- ;
- }
- }
- else if ((re_opcode_t) p1[3] == charset)
- {
- int idx;
- for (idx = 0;
- idx < (int) p2[1] && idx < (int) p1[4];
- idx++)
- if ((p2[2 + idx] & p1[5 + idx]) != 0)
- break;
- if (idx == p2[1] || idx == p1[4])
- {
- p[-3] = (unsigned char) pop_failure_jump;
- ;
- }
- }
- }
- }
- p -= 2;
- if ((re_opcode_t) p[-1] != pop_failure_jump)
- {
- p[-1] = (unsigned char) jump;
- ;
- goto unconditional_jump;
- }
- case pop_failure_jump:
- {
- active_reg_t dummy_low_reg, dummy_high_reg;
- unsigned char *pdummy = ((void *)0);
- const char *sdummy = ((void *)0);
- ;
- { active_reg_t this_reg; const unsigned char *string_temp; ; ; ; ; ; ; ; string_temp = fail_stack.stack[--fail_stack.avail].pointer; if (string_temp != ((void *)0)) sdummy = (const char *) string_temp; ; ; ; pdummy = (unsigned char *) fail_stack.stack[--fail_stack.avail].pointer; ; ; dummy_high_reg = (active_reg_t) fail_stack.stack[--fail_stack.avail].integer; ; dummy_low_reg = (active_reg_t) fail_stack.stack[--fail_stack.avail].integer; ; if (1) for (this_reg = dummy_high_reg; this_reg >= dummy_low_reg; this_reg--) { ; reg_info_dummy[this_reg].word = fail_stack.stack[--fail_stack.avail]; ; reg_dummy[this_reg] = (const char *) fail_stack.stack[--fail_stack.avail].pointer; ; reg_dummy[this_reg] = (const char *) fail_stack.stack[--fail_stack.avail].pointer; ; } else { for (this_reg = highest_active_reg; this_reg > dummy_high_reg; this_reg--) { reg_info_dummy[this_reg].word.integer = 0; reg_dummy[this_reg] = 0; reg_dummy[this_reg] = 0; } highest_active_reg = dummy_!
high_reg;
} set_regs_matched_done = 0; ; };
- }
- unconditional_jump:
- ;
- case jump:
- do { do { (mcnt) = *(p) & 0377; (mcnt) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- ;
- p += mcnt;
- ;
- break;
- case jump_past_alt:
- ;
- goto unconditional_jump;
- case dummy_failure_jump:
- ;
- do { char *destination; active_reg_t this_reg; ; ; ; ; ; ; ; while (((fail_stack).size - (fail_stack).avail) < (((0 ? 0 : highest_active_reg - lowest_active_reg + 1) * 3) + 4)) { if (!((fail_stack).size > (unsigned) (xre_max_failures * (5 * 3 + 4)) ? 0 : ((fail_stack).stack = (byte_fail_stack_elt_t *) (destination = (char *) __builtin_alloca (((fail_stack).size << 1) * sizeof (byte_fail_stack_elt_t)), memcpy (destination, (fail_stack).stack, (fail_stack).size * sizeof (byte_fail_stack_elt_t))), (fail_stack).stack == ((void *)0) ? 0 : ((fail_stack).size <<= 1, 1)))) return -2; ; ; } ; if (1) for (this_reg = lowest_active_reg; this_reg <= highest_active_reg; this_reg++) { ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regstart[this_reg]); ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regend[this_reg]); ; ; ; ; ; ; fail_stack.stack[fail_stack.avail++] = (reg_info[this_reg].word); } ; fail_stack.stack[fail_stack.avail++].!
integer =
(lowest_active_reg); ; fail_stack.stack[fail_stack.avail++].integer = (highest_active_reg); ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (((void *)0)); ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (((void *)0)); ; ; } while (0);
- goto unconditional_jump;
- case push_dummy_failure:
- ;
- do { char *destination; active_reg_t this_reg; ; ; ; ; ; ; ; while (((fail_stack).size - (fail_stack).avail) < (((0 ? 0 : highest_active_reg - lowest_active_reg + 1) * 3) + 4)) { if (!((fail_stack).size > (unsigned) (xre_max_failures * (5 * 3 + 4)) ? 0 : ((fail_stack).stack = (byte_fail_stack_elt_t *) (destination = (char *) __builtin_alloca (((fail_stack).size << 1) * sizeof (byte_fail_stack_elt_t)), memcpy (destination, (fail_stack).stack, (fail_stack).size * sizeof (byte_fail_stack_elt_t))), (fail_stack).stack == ((void *)0) ? 0 : ((fail_stack).size <<= 1, 1)))) return -2; ; ; } ; if (1) for (this_reg = lowest_active_reg; this_reg <= highest_active_reg; this_reg++) { ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regstart[this_reg]); ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (regend[this_reg]); ; ; ; ; ; ; fail_stack.stack[fail_stack.avail++] = (reg_info[this_reg].word); } ; fail_stack.stack[fail_stack.avail++].!
integer =
(lowest_active_reg); ; fail_stack.stack[fail_stack.avail++].integer = (highest_active_reg); ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (((void *)0)); ; ; ; fail_stack.stack[fail_stack.avail++].pointer = (unsigned char *) (((void *)0)); ; ; } while (0);
- break;
- case succeed_n:
- do { (mcnt) = *(p + 2) & 0377; (mcnt) += ((signed char) (*((p + 2) + 1))) << 8; } while (0);
- ;
- ;
- if (mcnt > 0)
- {
- mcnt--;
- p += 2;
- do { do { (p)[0] = (mcnt) & 0377; (p)[1] = (mcnt) >> 8; } while (0); (p) += 2; } while (0);
- ;
- }
- else if (mcnt == 0)
- {
- ;
- p[2] = (unsigned char) no_op;
- p[3] = (unsigned char) no_op;
- goto on_failure;
- }
- break;
- case jump_n:
- do { (mcnt) = *(p + 2) & 0377; (mcnt) += ((signed char) (*((p + 2) + 1))) << 8; } while (0);
- ;
- if (mcnt)
- {
- mcnt--;
- do { (p + 2)[0] = (mcnt) & 0377; (p + 2)[1] = (mcnt) >> 8; } while (0);
- ;
- goto unconditional_jump;
- }
- else
- p += 2 * 2;
- break;
- case set_number_at:
- {
- ;
- do { do { (mcnt) = *(p) & 0377; (mcnt) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- p1 = p + mcnt;
- do { do { (mcnt) = *(p) & 0377; (mcnt) += ((signed char) (*((p) + 1))) << 8; } while (0); (p) += 2; } while (0);
- ;
- do { (p1)[0] = (mcnt) & 0377; (p1)[1] = (mcnt) >> 8; } while (0);
- break;
- }
- case wordbound:
- {
- boolean prevchar, thischar;
- ;
- if (((d) == (size1 ? string1 : string2) || !size2) || ((d) == end2))
- break;
- prevchar = (re_syntax_table[(unsigned char) ((d - 1) == end1 ? *string2 : (d - 1) == string2 - 1 ? *(end1 - 1) : *(d - 1))] == 1);
- thischar = (re_syntax_table[(unsigned char) ((d) == end1 ? *string2 : (d) == string2 - 1 ? *(end1 - 1) : *(d))] == 1);
- if (prevchar != thischar)
- break;
- goto fail;
- }
- case notwordbound:
- {
- boolean prevchar, thischar;
- ;
- if (((d) == (size1 ? string1 : string2) || !size2) || ((d) == end2))
- goto fail;
- prevchar = (re_syntax_table[(unsigned char) ((d - 1) == end1 ? *string2 : (d - 1) == string2 - 1 ? *(end1 - 1) : *(d - 1))] == 1);
- thischar = (re_syntax_table[(unsigned char) ((d) == end1 ? *string2 : (d) == string2 - 1 ? *(end1 - 1) : *(d))] == 1);
- if (prevchar != thischar)
- goto fail;
- break;
- }
- case wordbeg:
- ;
- if (!((d) == end2) && (re_syntax_table[(unsigned char) ((d) == end1 ? *string2 : (d) == string2 - 1 ? *(end1 - 1) : *(d))] == 1)
- && (((d) == (size1 ? string1 : string2) || !size2) || !(re_syntax_table[(unsigned char) ((d - 1) == end1 ? *string2 : (d - 1) == string2 - 1 ? *(end1 - 1) : *(d - 1))] == 1)))
- break;
- goto fail;
- case wordend:
- ;
- if (!((d) == (size1 ? string1 : string2) || !size2) && (re_syntax_table[(unsigned char) ((d - 1) == end1 ? *string2 : (d - 1) == string2 - 1 ? *(end1 - 1) : *(d - 1))] == 1)
- && (((d) == end2) || !(re_syntax_table[(unsigned char) ((d) == end1 ? *string2 : (d) == string2 - 1 ? *(end1 - 1) : *(d))] == 1)))
- break;
- goto fail;
- case wordchar:
- ;
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- if (!(re_syntax_table[(unsigned char) ((d) == end1 ? *string2 : (d) == string2 - 1 ? *(end1 - 1) : *(d))] == 1))
- goto fail;
- do { if (!set_regs_matched_done) { active_reg_t r; set_regs_matched_done = 1; for (r = lowest_active_reg; r <= highest_active_reg; r++) { ((reg_info[r]).bits.matched_something) = ((reg_info[r]).bits.ever_matched_something) = 1; } } } while (0);
- d++;
- break;
- case notwordchar:
- ;
- while (d == dend) { if (dend == end_match_2) goto fail; d = string2; dend = end_match_2; };
- if ((re_syntax_table[(unsigned char) ((d) == end1 ? *string2 : (d) == string2 - 1 ? *(end1 - 1) : *(d))] == 1))
- goto fail;
- do { if (!set_regs_matched_done) { active_reg_t r; set_regs_matched_done = 1; for (r = lowest_active_reg; r <= highest_active_reg; r++) { ((reg_info[r]).bits.matched_something) = ((reg_info[r]).bits.ever_matched_something) = 1; } } } while (0);
- d++;
- break;
- default:
- abort ();
- }
- continue;
- fail:
- if (!(fail_stack.avail == 0))
- {
- ;
- { active_reg_t this_reg; const unsigned char *string_temp; ; ; ; ; ; ; ; string_temp = fail_stack.stack[--fail_stack.avail].pointer; if (string_temp != ((void *)0)) d = (const char *) string_temp; ; ; ; p = (unsigned char *) fail_stack.stack[--fail_stack.avail].pointer; ; ; highest_active_reg = (active_reg_t) fail_stack.stack[--fail_stack.avail].integer; ; lowest_active_reg = (active_reg_t) fail_stack.stack[--fail_stack.avail].integer; ; if (1) for (this_reg = highest_active_reg; this_reg >= lowest_active_reg; this_reg--) { ; reg_info[this_reg].word = fail_stack.stack[--fail_stack.avail]; ; regend[this_reg] = (const char *) fail_stack.stack[--fail_stack.avail].pointer; ; regstart[this_reg] = (const char *) fail_stack.stack[--fail_stack.avail].pointer; ; } else { for (this_reg = highest_active_reg; this_reg > highest_active_reg; this_reg--) { reg_info[this_reg].word.integer = 0; regend[this_reg] = 0; regstart[this_reg] = 0; } highest_active_reg = highest_active_reg!
; } set_r
egs_matched_done = 0; ; };
- if (!p)
- goto fail;
- ;
- if (p < pend)
- {
- boolean is_a_jump_n = 0;
- switch ((re_opcode_t) *p)
- {
- case jump_n:
- is_a_jump_n = 1;
- case maybe_pop_jump:
- case pop_failure_jump:
- case jump:
- p1 = p + 1;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- p1 += mcnt;
- if ((is_a_jump_n && (re_opcode_t) *p1 == succeed_n)
- || (!is_a_jump_n
- && (re_opcode_t) *p1 == on_failure_jump))
- goto fail;
- break;
- default:
- ;
- }
- }
- if (d >= string1 && d <= end1)
- dend = end_match_1;
- }
- else
- break;
- }
- if (best_regs_set)
- goto restore_best_regs;
- do { ; if (regstart) ((void)0); regstart = ((void *)0); if (regend) ((void)0); regend = ((void *)0); if (old_regstart) ((void)0); old_regstart = ((void *)0); if (old_regend) ((void)0); old_regend = ((void *)0); if (best_regstart) ((void)0); best_regstart = ((void *)0); if (best_regend) ((void)0); best_regend = ((void *)0); if (reg_info) ((void)0); reg_info = ((void *)0); if (reg_dummy) ((void)0); reg_dummy = ((void *)0); if (reg_info_dummy) ((void)0); reg_info_dummy = ((void *)0); } while (0);
- return -1;
-}
-static boolean
-byte_group_match_null_string_p (unsigned char **p, unsigned char *end,
- byte_register_info_type *reg_info)
-{
- int mcnt;
- unsigned char *p1 = *p + 2;
- while (p1 < end)
- {
- switch ((re_opcode_t) *p1)
- {
- case on_failure_jump:
- p1++;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- if (mcnt >= 0)
- {
- while ((re_opcode_t) p1[mcnt-(1+2)] ==
- jump_past_alt)
- {
- if (!byte_alt_match_null_string_p (p1, p1 + mcnt -
- (1 + 2),
- reg_info))
- return 0;
- p1 += mcnt;
- if ((re_opcode_t) *p1 != on_failure_jump)
- break;
- p1++;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- if ((re_opcode_t) p1[mcnt-(1+2)] !=
- jump_past_alt)
- {
- p1 -= 1 + 2;
- break;
- }
- }
- do { (mcnt) = *(p1 - 2) & 0377; (mcnt) += ((signed char) (*((p1 - 2) + 1))) << 8; } while (0);
- if (!byte_alt_match_null_string_p (p1, p1 + mcnt, reg_info))
- return 0;
- p1 += mcnt;
- }
- break;
- case stop_memory:
- ;
- *p = p1 + 2;
- return 1;
- default:
- if (!byte_common_op_match_null_string_p (&p1, end, reg_info))
- return 0;
- }
- }
- return 0;
-}
-static boolean
-byte_alt_match_null_string_p (unsigned char *p, unsigned char *end,
- byte_register_info_type *reg_info)
-{
- int mcnt;
- unsigned char *p1 = p;
- while (p1 < end)
- {
- switch ((re_opcode_t) *p1)
- {
- case on_failure_jump:
- p1++;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- p1 += mcnt;
- break;
- default:
- if (!byte_common_op_match_null_string_p (&p1, end, reg_info))
- return 0;
- }
- }
- return 1;
-}
-static boolean
-byte_common_op_match_null_string_p (unsigned char **p, unsigned char *end,
- byte_register_info_type *reg_info)
-{
- int mcnt;
- boolean ret;
- int reg_no;
- unsigned char *p1 = *p;
- switch ((re_opcode_t) *p1++)
- {
- case no_op:
- case begline:
- case endline:
- case begbuf:
- case endbuf:
- case wordbeg:
- case wordend:
- case wordbound:
- case notwordbound:
- break;
- case start_memory:
- reg_no = *p1;
- ;
- ret = byte_group_match_null_string_p (&p1, end, reg_info);
- if (((reg_info[reg_no]).bits.match_null_string_p) == 3)
- ((reg_info[reg_no]).bits.match_null_string_p) = ret;
- if (!ret)
- return 0;
- break;
- case jump:
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- if (mcnt >= 0)
- p1 += mcnt;
- else
- return 0;
- break;
- case succeed_n:
- p1 += 2;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- if (mcnt == 0)
- {
- p1 -= 2 * 2;
- do { do { (mcnt) = *(p1) & 0377; (mcnt) += ((signed char) (*((p1) + 1))) << 8; } while (0); (p1) += 2; } while (0);
- p1 += mcnt;
- }
- else
- return 0;
- break;
- case duplicate:
- if (!((reg_info[*p1]).bits.match_null_string_p))
- return 0;
- break;
- case set_number_at:
- p1 += 2 * 2;
- default:
- return 0;
- }
- *p = p1;
- return 1;
-}
-static int
-byte_bcmp_translate (const char *s1, const char *s2, register int len,
- char * translate)
-{
- register const unsigned char *p1 = (const unsigned char *) s1;
- register const unsigned char *p2 = (const unsigned char *) s2;
- while (len)
- {
- if (translate[*p1++] != translate[*p2++]) return 1;
- len--;
- }
- return 0;
-}
-reg_syntax_t xre_syntax_options;
-reg_syntax_t
-xre_set_syntax (reg_syntax_t syntax)
-{
- reg_syntax_t ret = xre_syntax_options;
- xre_syntax_options = syntax;
- return ret;
-}
-static const char *re_error_msgid[] =
- {
- "Success",
- "No match",
- "Invalid regular expression",
- "Invalid collation character",
- "Invalid character class name",
- "Trailing backslash",
- "Invalid back reference",
- "Unmatched [ or [^",
- "Unmatched ( or \\(",
- "Unmatched \\{",
- "Invalid content of \\{\\}",
- "Invalid range end",
- "Memory exhausted",
- "Invalid preceding regular expression",
- "Premature end of regular expression",
- "Regular expression too big",
- "Unmatched ) or \\)"
- };
-static boolean
-group_in_compile_stack (compile_stack_type compile_stack, regnum_t regnum)
-{
- int this_element;
- for (this_element = compile_stack.avail - 1;
- this_element >= 0;
- this_element--)
- if (compile_stack.stack[this_element].regnum == regnum)
- return 1;
- return 0;
-}
-int
-xre_compile_fastmap (struct re_pattern_buffer *bufp)
-{
- return byte_re_compile_fastmap(bufp);
-}
-void
-xre_set_registers (struct re_pattern_buffer *bufp,
- struct re_registers *regs, unsigned num_regs,
- regoff_t *starts, regoff_t *ends)
-{
- if (num_regs)
- {
- bufp->regs_allocated = 1;
- regs->num_regs = num_regs;
- regs->start = starts;
- regs->end = ends;
- }
- else
- {
- bufp->regs_allocated = 0;
- regs->num_regs = 0;
- regs->start = regs->end = (regoff_t *) 0;
- }
-}
-int
-xre_search (struct re_pattern_buffer *bufp, const char *string, int size,
- int startpos, int range, struct re_registers *regs)
-{
- return xre_search_2 (bufp, ((void *)0), 0, string, size, startpos, range,
- regs, size);
-}
-int
-xre_search_2 (struct re_pattern_buffer *bufp, const char *string1, int size1,
- const char *string2, int size2, int startpos, int range,
- struct re_registers *regs, int stop)
-{
- return byte_re_search_2 (bufp, string1, size1, string2, size2, startpos,
- range, regs, stop);
-}
-int
-xre_match (struct re_pattern_buffer *bufp, const char *string,
- int size, int pos, struct re_registers *regs)
-{
- int result;
- result = byte_re_match_2_internal (bufp, ((void *)0), 0, string, size,
- pos, regs, size);
- return result;
-}
-int
-xre_match_2 (struct re_pattern_buffer *bufp, const char *string1, int size1,
- const char *string2, int size2, int pos,
- struct re_registers *regs, int stop)
-{
- int result;
- result = byte_re_match_2_internal (bufp, string1, size1, string2, size2,
- pos, regs, stop);
- return result;
-}
-const char *
-xre_compile_pattern (const char *pattern, size_t length,
- struct re_pattern_buffer *bufp)
-{
- reg_errcode_t ret;
- bufp->regs_allocated = 0;
- bufp->no_sub = 0;
- bufp->newline_anchor = 1;
- ret = byte_regex_compile (pattern, length, xre_syntax_options, bufp);
- if (!ret)
- return ((void *)0);
- return (re_error_msgid[(int) ret]);
-}
-static struct re_pattern_buffer re_comp_buf;
-char *
-xre_comp (const char *s)
-{
- reg_errcode_t ret;
- if (!s)
- {
- if (!re_comp_buf.buffer)
- return (char *) ("No previous regular expression");
- return 0;
- }
- if (!re_comp_buf.buffer)
- {
- re_comp_buf.buffer = (unsigned char *) malloc (200);
- if (re_comp_buf.buffer == ((void *)0))
- return (char *) (re_error_msgid[(int) REG_ESPACE]);
- re_comp_buf.allocated = 200;
- re_comp_buf.fastmap = (char *) malloc (1 << 8);
- if (re_comp_buf.fastmap == ((void *)0))
- return (char *) (re_error_msgid[(int) REG_ESPACE]);
- }
- re_comp_buf.newline_anchor = 1;
- ret = byte_regex_compile (s, strlen (s), xre_syntax_options, &re_comp_buf);
- if (!ret)
- return ((void *)0);
- return (char *) (re_error_msgid[(int) ret]);
-}
-int
-xre_exec (const char *s)
-{
- const int len = strlen (s);
- return
- 0 <= xre_search (&re_comp_buf, s, len, 0, len, (struct re_registers *) 0);
-}
-int
-xregcomp (regex_t *preg, const char *pattern, int cflags)
-{
- reg_errcode_t ret;
- reg_syntax_t syntax
- = (cflags & 1) ?
- ((((((unsigned long int) 1) << 1) << 1) | ((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | ((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)) | (((((unsigned long int) 1) << 1) << 1) << 1) | ((((((unsigned long int) 1) << 1) << 1) << 1) << 1) | ((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) | (((((((((((((((((((unsigned long int) 1) << 1) <<!
1) << 1)
<< 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)) : ((((((unsigned long int) 1) << 1) << 1) | ((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | (((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) | ((((((((((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1)) | (((unsigned long int) 1) << 1));
- preg->buffer = 0;
- preg->allocated = 0;
- preg->used = 0;
- preg->fastmap = (char *) malloc (1 << 8);
- if (cflags & (1 << 1))
- {
- int i;
- preg->translate
- = (char *) malloc (256
- * sizeof (*(char *)0));
- if (preg->translate == ((void *)0))
- return (int) REG_ESPACE;
- for (i = 0; i < 256; i++)
- preg->translate[i] = (1 && ((*__ctype_b_loc ())[(int) ((i))] & (unsigned short int) _ISupper)) ? ((int) (*__ctype_tolower_loc ())[(int) (i)]) : i;
- }
- else
- preg->translate = ((void *)0);
- if (cflags & ((1 << 1) << 1))
- {
- syntax &= ~((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1);
- syntax |= ((((((((((unsigned long int) 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1) << 1);
- preg->newline_anchor = 1;
- }
- else
- preg->newline_anchor = 0;
- preg->no_sub = !!(cflags & (((1 << 1) << 1) << 1));
- ret = byte_regex_compile (pattern, strlen (pattern), syntax, preg);
- if (ret == REG_ERPAREN) ret = REG_EPAREN;
- if (ret == REG_NOERROR && preg->fastmap)
- {
- if (xre_compile_fastmap (preg) == -2)
- {
- free (preg->fastmap);
- preg->fastmap = ((void *)0);
- }
- }
- return (int) ret;
-}
-int
-xregexec (const regex_t *preg, const char *string, size_t nmatch,
- regmatch_t pmatch[], int eflags)
-{
- int ret;
- struct re_registers regs;
- regex_t private_preg;
- int len = strlen (string);
- boolean want_reg_info = !preg->no_sub && nmatch > 0;
- private_preg = *preg;
- private_preg.not_bol = !!(eflags & 1);
- private_preg.not_eol = !!(eflags & (1 << 1));
- private_preg.regs_allocated = 2;
- if (want_reg_info)
- {
- regs.num_regs = nmatch;
- regs.start = ((regoff_t *) malloc ((nmatch * 2) * sizeof (regoff_t)));
- if (regs.start == ((void *)0))
- return (int) REG_NOMATCH;
- regs.end = regs.start + nmatch;
- }
- ret = xre_search (&private_preg, string, len,
- 0, len,
- want_reg_info ? ®s : (struct re_registers *) 0);
- if (want_reg_info)
- {
- if (ret >= 0)
- {
- unsigned r;
- for (r = 0; r < nmatch; r++)
- {
- pmatch[r].rm_so = regs.start[r];
- pmatch[r].rm_eo = regs.end[r];
- }
- }
- free (regs.start);
- }
- return ret >= 0 ? (int) REG_NOERROR : (int) REG_NOMATCH;
-}
-size_t
-xregerror (int errcode, const regex_t *preg __attribute__ ((__unused__)),
- char *errbuf, size_t errbuf_size)
-{
- const char *msg;
- size_t msg_size;
- if (errcode < 0
- || errcode >= (int) (sizeof (re_error_msgid)
- / sizeof (re_error_msgid[0])))
- abort ();
- msg = (re_error_msgid[errcode]);
- msg_size = strlen (msg) + 1;
- if (errbuf_size != 0)
- {
- if (msg_size > errbuf_size)
- {
- *((char *) mempcpy (errbuf, msg, errbuf_size - 1)) = '\0';
- }
- else
- memcpy (errbuf, msg, msg_size);
- }
- return msg_size;
-}
-void
-xregfree (regex_t *preg)
-{
- if (preg->buffer != ((void *)0))
- free (preg->buffer);
- preg->buffer = ((void *)0);
- preg->allocated = 0;
- preg->used = 0;
- if (preg->fastmap != ((void *)0))
- free (preg->fastmap);
- preg->fastmap = ((void *)0);
- preg->fastmap_accurate = 0;
- if (preg->translate != ((void *)0))
- free (preg->translate);
- preg->translate = ((void *)0);
-}
Removed: dragonegg/trunk/test/compilator/local/test_fpu.f90
URL: http://llvm.org/viewvc/llvm-project/dragonegg/trunk/test/compilator/local/test_fpu.f90?rev=176082&view=auto
==============================================================================
--- dragonegg/trunk/test/compilator/local/test_fpu.f90 (original)
+++ dragonegg/trunk/test/compilator/local/test_fpu.f90 (removed)
@@ -1,4447 +0,0 @@
-! EXAMPLE creating TEST_FPU.EXE using Compaq Visual Fortran -- CVF 6.6
-! DF /c LAPACK.F
-! DF TEST_FPU LAPACK.OBJ /LINK INTEL.LIB /STACK:8000000
-! 128mb Memory is required to avoid paging
-
-! --------------------------------------------------------------------
-MODULE kinds
- INTEGER, PARAMETER :: RK8 = SELECTED_REAL_KIND(15, 300)
-END MODULE kinds
-! --------------------------------------------------------------------
-PROGRAM TEST_FPU ! A number-crunching benchmark using matrix inversion.
-USE kinds ! Implemented by: David Frank Dave_Frank at hotmail.com
-IMPLICIT NONE ! Gauss routine by: Tim Prince N8TM at aol.com
- ! Crout routine by: James Van Buskirk torsop at ix.netcom.com
- ! Lapack routine by: Jos Bergervoet bergervo at IAEhv.nl
-
-! - - - local variables - - -
-REAL(RK8) :: pool(101,101,1000), pool3(1001,1001) ! random numbers to invert
-EQUIVALENCE (pool,pool3) ! use same pool numbers for test 3,4
-REAL(RK8) :: a(101,101), a3(1001,1001) ! working matrices
-
-REAL(RK8) :: avg_err, dt(4)
-INTEGER :: i, n, t(8), clock1, clock2, rate
-
-CHARACTER (LEN=36) :: invert_id(4) = &
- (/ 'Test1 - Gauss 2000 (101x101) inverts', &
- 'Test2 - Crout 2000 (101x101) inverts', &
- 'Test3 - Crout 2 (1001x1001) inverts', &
- 'Test4 - Lapack 2 (1001x1001) inverts' /)
-! - - - - - - - - - - - - - -
-
-WRITE (*,*) ' Benchmark running, hopefully as only ACTIVE task'
-
-CALL DATE_AND_TIME ( values = t )
-
-CALL RANDOM_SEED() ! set seed to random number based on time
-CALL RANDOM_NUMBER(pool) ! fill pool with random data ( 0. -> 1. )
-
-! - - - begin benchmark - - -
-
-DO n = 1,4
-
- CALL SYSTEM_CLOCK (clock1,rate) ! get benchmark (n) start time
-
- SELECT CASE (n)
- CASE (1:2)
- DO i = 1,1000
- a = pool(:,:,i) ! get next matrix to invert
- IF (n == 1) THEN
- CALL Gauss (a,101) ! invert a
- CALL Gauss (a,101) ! invert a
- ELSE
- CALL Crout (a,101) ! invert a
- CALL Crout (a,101) ! invert a
- END IF
- END DO
- avg_err = SUM(ABS(a-pool(:,:,1000)))/(101*101) ! last matrix error
-
- CASE (3:4)
- a3 = pool3 ! get 1001x1001 matrix
- IF (n == 3) THEN
- CALL Crout (a3,1001) ! invert a3
- CALL Crout (a3,1001) ! invert a3
- ELSE
- CALL Lapack (a3,1001) ! invert a3
- CALL Lapack (a3,1001) ! invert a3
- END IF
- avg_err = SUM(ABS(a3-pool3))/(1001*1001) ! invert err.
-
- END SELECT
-
- CALL SYSTEM_CLOCK (clock2,rate)
- dt(n) = (clock2-clock1)/DBLE(rate) ! get benchmark (n) elapsed sec.
-
- WRITE (*,92) invert_id(n), dt(n), ' sec Err=', avg_err
-
-END DO ! for test 1-4
-
-WRITE (*,92) ' total =',SUM(dt), ' sec'
-WRITE (*,*)
-
-
-91 FORMAT (A,I4,2('/',I2.2))
-92 FORMAT (A,F5.1,A,F18.15)
-
-END PROGRAM TEST_FPU
-
-! --------------------------------------------------------------------
-SUBROUTINE Gauss (a,n) ! Invert matrix by Gauss method
-! --------------------------------------------------------------------
-USE kinds
-IMPLICIT NONE
-
-INTEGER :: n
-REAL(RK8) :: a(n,n)
-
-! - - - Local Variables - - -
-REAL(RK8) :: b(n,n), c, d, temp(n)
-INTEGER :: i, j, k, m, imax(1), ipvt(n)
-! - - - - - - - - - - - - - -
-b = a
-ipvt = (/ (i, i = 1, n) /)
-
-DO k = 1,n
- imax = MAXLOC(ABS(b(k:n,k)))
- m = k-1+imax(1)
-
- IF (m /= k) THEN
- ipvt( (/m,k/) ) = ipvt( (/k,m/) )
- b((/m,k/),:) = b((/k,m/),:)
- END IF
- d = 1/b(k,k)
-
- temp = b(:,k)
- DO j = 1, n
- c = b(k,j)*d
- b(:,j) = b(:,j)-temp*c
- b(k,j) = c
- END DO
- b(:,k) = temp*(-d)
- b(k,k) = d
-END DO
-a(:,ipvt) = b
-
-END SUBROUTINE Gauss
-
-! -------------------------------------------------------------------
-SUBROUTINE Crout (a,n) ! Invert matrix by Crout method
-! -------------------------------------------------------------------
-USE kinds
-IMPLICIT NONE
-
-INTEGER :: n ! Order of the matrix
-REAL(RK8) :: a(n,n) ! Matrix to be inverted
-
-INTEGER :: i, j, m, imax(1) ! Current row & column, max pivot loc
-INTEGER :: index(n) ! Partial pivot record
-REAL(RK8) :: b(n,n), temp(n) ! working arrays, temp
-
-index = (/(i,i=1,n)/) ! initialize column index
-
-DO j = 1, n ! Shuffle matrix a -> b
- DO i = 1, j-1
- b(i, j) = a(i, j)
- END DO
- DO i = j, n
- b(i, j) = a(n+1-j, i+1-j)
- END DO
-END DO
-
-DO j = 1, n ! LU decomposition; reciprocals of diagonal elements in L matrix
-
- DO i = j, n ! Get current column of L matrix
- b(n-i+j,n+1-i) = b(n-i+j,n+1-i)-DOT_PRODUCT(b(n+1-i:n-i+j-1,n+1-i), b(1:j-1,j))
- END DO
-
- imax = MAXLOC(ABS( (/ (b(j+i-1,i),i=1,n-j+1) /) ))
- m = imax(1)
- b(j+m-1,m) = 1/b(j+m-1,m)
-
- IF (m /= n+1-j) THEN ! Swap biggest element to current pivot position
- index((/j,n+1-m/)) = index((/n+1-m,j/))
- b((/j,n+1-m/),n+2-m:n) = b((/n+1-m,j/),n+2-m:n)
- temp(1:n+1-m) = b(m:n, m)
- b(m:j-1+m, m) = b(n+1-j:n, n+1-j)
- b(j+m:n, m) = b(j, j+1:n+1-m)
- b(n+1-j:n, n+1-j) = temp(1:j)
- b(j, j+1:n+1-m) = temp(j+1:n+1-m)
- END IF
-
- DO i = j+1, n ! Get current row of U matrix
- b(j,i) = b(n,n+1-j)*(b(j,i)-DOT_PRODUCT(b(n+1-j:n-1,n+1-j),b(1:j-1,i)))
- END DO
-END DO
-
-DO j = 1, n-1 ! Invert L matrix
- temp(1) = b(n, n+1-j)
- DO i = j+1, n
- b(n-i+j,n+1-i) = -DOT_PRODUCT(b(n-i+j:n-1,n+1-i),temp(1:i-j))*b(n,n+1-i)
- temp(i-j+1) = b(n-i+j,n+1-i)
- END DO
-END DO
-
-DO i = 1, (n+1)/3 ! Reshuffle matrix
- temp(1:n+2-3*i) = b(2*i:n+1-i,i)
- DO j = 2*i, n+1-i
- b(j, i) = b(n+i-j, n+1-j)
- END DO
- DO j = i, n+1-2*i
- b(i+j-1, j) = b(n+1-i, n+2-i-j)
- END DO
- b(n+1-i, i+1:n+2-2*i) = temp(1:n+2-3*i)
-END DO
-
-DO i = 1, n-1 ! Invert U matrix
- DO j = i+1, n
- b(i,j) = -b(i,j)-DOT_PRODUCT(temp(1:j-i-1), b(i+1:j-1,j))
- temp(j-i) = b(i,j)
- END DO
-END DO
-
-DO i = 1, n-1 ! Multiply inverses in reverse order
- temp(1:n-i) = b(i,i+1:n)
- DO j = 1,i
- b(i,j) = b(i,j)+DOT_PRODUCT(temp(1:n-i),b(i+1:n,j))
- END DO
- DO j = i+1, n
- b(i,j) = DOT_PRODUCT(temp(j-i:n-i),b(j:n,j))
- END DO
-END DO
-
-a(:,index) = b ! output straightened columns of the inverse
-
-END SUBROUTINE Crout
-
-! --------------------------------------------------------------------
-SUBROUTINE Lapack (a,n) ! Invert matrix by Lapack method
-! --------------------------------------------------------------------
-USE kinds
-IMPLICIT NONE
-
-INTEGER :: n
-REAL(RK8) :: a(n,n)
-
-INTEGER :: ipiv(n)
-INTEGER :: info, lwork, ILAENV
-REAL(RK8), ALLOCATABLE :: work(:)
-
-lwork = n * ILAENV( 1, 'DGETRI', ' ', n, -1, -1, -1 )
-ALLOCATE ( work(lwork) )
-
-CALL DGETRF( n, n, a, n, ipiv, info )
-CALL DGETRI( n, a, n, ipiv, work, lwork, info )
-
-DEALLOCATE ( work )
-
-END SUBROUTINE Lapack
-
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DGEMM
- INTERFACE
- SUBROUTINE DGEMM(Transa,Transb,M,N,K,Alpha,A,Lda,B,Ldb,Beta,C,Ldc)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
- DOUBLE PRECISION :: Alpha , Beta
- INTEGER :: K , Lda , Ldb , Ldc , M , N
- CHARACTER(1) :: Transa , Transb
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(Ldb,*) :: B
- DOUBLE PRECISION , DIMENSION(Ldc,*) :: C
- INTENT (IN) A , Alpha , B , Beta , K , Lda , Ldb , Ldc , M , N
- INTENT (INOUT) C
- END SUBROUTINE DGEMM
- END INTERFACE
-END MODULE S_DGEMM
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DGEMV
- INTERFACE
- SUBROUTINE DGEMV(Trans,M,N,Alpha,A,Lda,X,Incx,Beta,Y,Incy)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
- DOUBLE PRECISION :: Alpha , Beta
- INTEGER :: Incx , Incy , Lda , M , N
- CHARACTER(1) :: Trans
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(*) :: X , Y
- INTENT (IN) A , Alpha , Beta , Incx , Incy , Lda , M , N , X
- INTENT (INOUT) Y
- END SUBROUTINE DGEMV
- END INTERFACE
-END MODULE S_DGEMV
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DGER
- INTERFACE
- SUBROUTINE DGER(M,N,Alpha,X,Incx,Y,Incy,A,Lda)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ZERO = 0.0D+0
- DOUBLE PRECISION :: Alpha
- INTEGER :: Incx , Incy , Lda , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(*) :: X , Y
- INTENT (IN) Alpha , Incx , Incy , Lda , M , N , X , Y
- INTENT (INOUT) A
- END SUBROUTINE DGER
- END INTERFACE
-END MODULE S_DGER
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DSCAL
- INTERFACE
- SUBROUTINE DSCAL(N,Da,Dx,Incx)
- IMPLICIT NONE
- DOUBLE PRECISION :: Da
- INTEGER :: Incx , N
- DOUBLE PRECISION , DIMENSION(*) :: Dx
- INTENT (IN) Da , Incx , N
- INTENT (INOUT) Dx
- END SUBROUTINE DSCAL
- END INTERFACE
-END MODULE S_DSCAL
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DSWAP
- INTERFACE
- SUBROUTINE DSWAP(N,Dx,Incx,Dy,Incy)
- IMPLICIT NONE
- INTEGER :: Incx , Incy , N
- DOUBLE PRECISION , DIMENSION(*) :: Dx , Dy
- INTENT (IN) Incx , Incy , N
- INTENT (INOUT) Dx , Dy
- END SUBROUTINE DSWAP
- END INTERFACE
-END MODULE S_DSWAP
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DTRMM
- INTERFACE
- SUBROUTINE DTRMM(Side,Uplo,Transa,Diag,M,N,Alpha,A,Lda,B,Ldb)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
- DOUBLE PRECISION :: Alpha
- CHARACTER(1) :: Diag , Side , Transa , Uplo
- INTEGER :: Lda , Ldb , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(Ldb,*) :: B
- INTENT (IN) A , Alpha , Lda , Ldb , M , N
- INTENT (INOUT) B
- END SUBROUTINE DTRMM
- END INTERFACE
-END MODULE S_DTRMM
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DTRMV
- INTERFACE
- SUBROUTINE DTRMV(Uplo,Trans,Diag,N,A,Lda,X,Incx)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ZERO = 0.0D+0
- CHARACTER(1) :: Diag , Trans , Uplo
- INTEGER :: Incx , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(*) :: X
- INTENT (IN) A , Incx , Lda , N
- INTENT (INOUT) X
- END SUBROUTINE DTRMV
- END INTERFACE
-END MODULE S_DTRMV
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DTRSM
- INTERFACE
- SUBROUTINE DTRSM(Side,Uplo,Transa,Diag,M,N,Alpha,A,Lda,B,Ldb)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
- DOUBLE PRECISION :: Alpha
- CHARACTER(1) :: Diag , Side , Transa , Uplo
- INTEGER :: Lda , Ldb , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(Ldb,*) :: B
- INTENT (IN) A , Alpha , Lda , Ldb , M , N
- INTENT (INOUT) B
- END SUBROUTINE DTRSM
- END INTERFACE
-END MODULE S_DTRSM
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_IDAMAX
- INTERFACE
- FUNCTION IDAMAX(N,Dx,Incx)
- IMPLICIT NONE
- INTEGER :: Incx , N
- DOUBLE PRECISION , DIMENSION(*) :: Dx
- INTEGER :: IDAMAX
- INTENT (IN) Dx , Incx , N
- END FUNCTION IDAMAX
- END INTERFACE
-END MODULE S_IDAMAX
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_XERBLA
- INTERFACE
- SUBROUTINE XERBLA(Srname,Info)
- IMPLICIT NONE
- INTEGER :: Info
- CHARACTER(6) :: Srname
- INTENT (IN) Info , Srname
- END SUBROUTINE XERBLA
- END INTERFACE
-END MODULE S_XERBLA
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DGETF2
- INTERFACE
- SUBROUTINE DGETF2(M,N,A,Lda,Ipiv,Info)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
- INTEGER :: Info , Lda , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- INTENT (IN) M
- INTENT (OUT) Ipiv
- INTENT (INOUT) Info
- END SUBROUTINE DGETF2
- END INTERFACE
-END MODULE S_DGETF2
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DGETRF
- INTERFACE
- SUBROUTINE DGETRF(M,N,A,Lda,Ipiv,Info)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0
- INTEGER :: Info , Lda , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- INTENT (INOUT) Info , Ipiv
- END SUBROUTINE DGETRF
- END INTERFACE
-END MODULE S_DGETRF
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DGETRI
- INTERFACE
- SUBROUTINE DGETRI(N,A,Lda,Ipiv,Work,Lwork,Info)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ZERO = 0.0D+0 , ONE = 1.0D+0
- INTEGER :: Info , Lda , Lwork , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- DOUBLE PRECISION , DIMENSION(Lwork) :: Work
- INTENT (IN) Ipiv , Lwork
- INTENT (INOUT) A , Info
- END SUBROUTINE DGETRI
- END INTERFACE
-END MODULE S_DGETRI
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DLASWP
- INTERFACE
- SUBROUTINE DLASWP(N,A,Lda,K1,K2,Ipiv,Incx)
- IMPLICIT NONE
- INTEGER :: Incx , K1 , K2 , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- INTENT (IN) Incx , Ipiv , K1 , K2
- END SUBROUTINE DLASWP
- END INTERFACE
-END MODULE S_DLASWP
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DTRTI2
- INTERFACE
- SUBROUTINE DTRTI2(Uplo,Diag,N,A,Lda,Info)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0
- CHARACTER :: Diag , Uplo
- INTEGER :: Info , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTENT (IN) N
- INTENT (INOUT) A , Info
- END SUBROUTINE DTRTI2
- END INTERFACE
-END MODULE S_DTRTI2
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_DTRTRI
- INTERFACE
- SUBROUTINE DTRTRI(Uplo,Diag,N,A,Lda,Info)
- IMPLICIT NONE
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
- CHARACTER :: Diag , Uplo
- INTEGER :: Info , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTENT (INOUT) Info
- END SUBROUTINE DTRTRI
- END INTERFACE
-END MODULE S_DTRTRI
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_ILAENV
- INTERFACE
- FUNCTION ILAENV(Ispec,Name,Opts,N1,N2,N3,N4)
- IMPLICIT NONE
- INTEGER :: Ispec , N1 , N2 , N3 , N4
- CHARACTER(*) :: Name , Opts
- INTEGER :: ILAENV
- INTENT (IN) Ispec , N1 , N2 , N4 , Name
- END FUNCTION ILAENV
- END INTERFACE
-END MODULE S_ILAENV
-!*==intfaces.f90 created by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-MODULE S_LSAME
- INTERFACE
- FUNCTION LSAME(Ca,Cb)
- IMPLICIT NONE
- CHARACTER :: Ca , Cb
- LOGICAL :: LSAME
- INTENT (IN) Ca , Cb
- END FUNCTION LSAME
- END INTERFACE
-END MODULE S_LSAME
-!*==DGETF2.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-!****************************************************************************
-! LAPACK routines for inversion of a matrix are included below; they are:
-! dgetf2 dgetrf dgetri dlaswp dtrti2 dtrtri ilaenv lsame
-!
-! The BLAS routines that are called by LAPACK are not included.
-! You can either use standard BLAS (from netlib) or processor-
-! optimized (like INTEL mkl library). The necessary BLAS routines
-! are:
-! dgemm dger dswap dtrmv idamax
-! dgemv dscal dtrmm dtrsm xerbla
-!
-! J. Bergervoet
-! May, 1998
-!****************************************************************************
-
- SUBROUTINE DGETF2(M,N,A,Lda,Ipiv,Info)
- USE S_DGER
- USE S_DSCAL
- USE S_DSWAP
- USE S_IDAMAX
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - M
-!A INPUT - N
-!A INPUT - A
-!A INPUT - LDA
-!A OUTPUT - IPIV
-!A OUTPUT - INFO
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls DGER DSCAL DSWAP IDAMAX XERBLA
-! called by DGETRF
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars J JP
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- INTEGER :: Info , Lda , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- INTENT (IN) M
- INTENT (OUT) Ipiv
- INTENT (INOUT) Info
-!
-! Local variables
-!
- INTEGER :: j , jp
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! June 30, 1992
-!
-! .. Scalar Arguments ..
-! ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DGETF2 computes an LU factorization of a general m-by-n matrix A
-! using partial pivoting with row interchanges.
-!
-! The factorization has the form
-! A = P * L * U
-! where P is a permutation matrix, L is lower triangular with unit
-! diagonal elements (lower trapezoidal if m > n), and U is upper
-! triangular (upper trapezoidal if m < n).
-!
-! This is the right-looking Level 2 BLAS version of the algorithm.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A. M >= 0.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A. N >= 0.
-!
-! A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-! On entry, the m by n matrix to be factored.
-! On exit, the factors L and U from the factorization
-! A = P*L*U; the unit diagonal elements of L are not stored.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! IPIV (output) INTEGER array, dimension (min(M,N))
-! The pivot indices; for 1 <= i <= min(M,N), row i of the
-! matrix was interchanged with row IPIV(i).
-!
-! INFO (output) INTEGER
-! = 0: successful exit
-! < 0: if INFO = -k, the k-th argument had an illegal value
-! > 0: if INFO = k, U(k,k) is exactly zero. The factorization
-! has been completed, but the factor U is exactly
-! singular, and division by zero will occur if it is used
-! to solve a system of equations.
-!
-! =====================================================================
-!
-! .. Parameters ..
-! ..
-! .. Local Scalars ..
-! ..
-! .. External Functions ..
-! ..
-! .. External Subroutines ..
-! ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- Info = 0
- IF ( M<0 ) THEN
- Info = -1
- ELSEIF ( N<0 ) THEN
- Info = -2
- ELSEIF ( Lda<MAX(1,M) ) THEN
- Info = -4
- ENDIF
- IF ( Info/=0 ) THEN
- CALL XERBLA('DGETF2',-Info)
- RETURN
- ENDIF
-!
-! Quick return if possible
-!
- IF ( M==0 .OR. N==0 ) RETURN
-!
- DO j = 1 , MIN(M,N)
-!
-! Find pivot and test for singularity.
-!
- jp = j - 1 + IDAMAX(M-j+1,A(j,j),1)
- Ipiv(j) = jp
- IF ( A(jp,j)/=ZERO ) THEN
-!
-! Apply the interchange to columns 1:N.
-!
- IF ( jp/=j ) CALL DSWAP(N,A(j,1),Lda,A(jp,1),Lda)
-!
-! Compute elements J+1:M of J-th column.
-!
- IF ( j<M ) CALL DSCAL(M-j,ONE/A(j,j),A(j+1,j),1)
-!
- ELSEIF ( Info==0 ) THEN
-!
- Info = j
- ENDIF
-!
-!
-! Update trailing submatrix.
-!
- IF ( j<MIN(M,N) ) CALL DGER(M-j,N-j,-ONE,A(j+1,j),1,A(j,j+1), &
- & Lda,A(j+1,j+1),Lda)
- ENDDO
-!
-! End of DGETF2
-!
- END SUBROUTINE DGETF2
-!*==DGETRF.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-
-
- SUBROUTINE DGETRF(M,N,A,Lda,Ipiv,Info)
- USE S_DGEMM
- USE S_DGETF2
- USE S_DLASWP
- USE S_DTRSM
- USE S_ILAENV
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - M
-!A INPUT - N
-!A PASSED - A
-!A INPUT - LDA
-!A OUTPUT - IPIV
-!A OUTPUT - INFO
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls DGEMM DGETF2 DLASWP DTRSM ILAENV XERBLA
-! called by ** NOTHING **
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I IINFO J JB NB
-! uses PARAMs ONE
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0
-!
-! Dummy arguments
-!
- INTEGER :: Info , Lda , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- INTENT (INOUT) Info , Ipiv
-!
-! Local variables
-!
- INTEGER :: i , iinfo , j , jb , nb
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! March 31, 1993
-!
-! .. Scalar Arguments ..
-! ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DGETRF computes an LU factorization of a general M-by-N matrix A
-! using partial pivoting with row interchanges.
-!
-! The factorization has the form
-! A = P * L * U
-! where P is a permutation matrix, L is lower triangular with unit
-! diagonal elements (lower trapezoidal if m > n), and U is upper
-! triangular (upper trapezoidal if m < n).
-!
-! This is the right-looking Level 3 BLAS version of the algorithm.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A. M >= 0.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A. N >= 0.
-!
-! A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-! On entry, the M-by-N matrix to be factored.
-! On exit, the factors L and U from the factorization
-! A = P*L*U; the unit diagonal elements of L are not stored.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! IPIV (output) INTEGER array, dimension (min(M,N))
-! The pivot indices; for 1 <= i <= min(M,N), row i of the
-! matrix was interchanged with row IPIV(i).
-!
-! INFO (output) INTEGER
-! = 0: successful exit
-! < 0: if INFO = -i, the i-th argument had an illegal value
-! > 0: if INFO = i, U(i,i) is exactly zero. The factorization
-! has been completed, but the factor U is exactly
-! singular, and division by zero will occur if it is used
-! to solve a system of equations.
-!
-! =====================================================================
-!
-! .. Parameters ..
-! ..
-! .. Local Scalars ..
-! ..
-! .. External Subroutines ..
-! ..
-! .. External Functions ..
-! ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- Info = 0
- IF ( M<0 ) THEN
- Info = -1
- ELSEIF ( N<0 ) THEN
- Info = -2
- ELSEIF ( Lda<MAX(1,M) ) THEN
- Info = -4
- ENDIF
- IF ( Info/=0 ) THEN
- CALL XERBLA('DGETRF',-Info)
- RETURN
- ENDIF
-!
-! Quick return if possible
-!
- IF ( M==0 .OR. N==0 ) RETURN
-!
-! Determine the block size for this environment.
-!
- nb = ILAENV(1,'DGETRF',' ',M,N,-1,-1)
- IF ( nb<=1 .OR. nb>=MIN(M,N) ) THEN
-!
-! Use unblocked code.
-!
- CALL DGETF2(M,N,A,Lda,Ipiv,Info)
- ELSE
-!
-! Use blocked code.
-!
- DO j = 1 , MIN(M,N) , nb
- jb = MIN(MIN(M,N)-j+1,nb)
-!
-! Factor diagonal and subdiagonal blocks and test for exact
-! singularity.
-!
- CALL DGETF2(M-j+1,jb,A(j,j),Lda,Ipiv(j),iinfo)
-!
-! Adjust INFO and the pivot indices.
-!
- IF ( Info==0 .AND. iinfo>0 ) Info = iinfo + j - 1
- DO i = j , MIN(M,j+jb-1)
- Ipiv(i) = j - 1 + Ipiv(i)
- ENDDO
-!
-! Apply interchanges to columns 1:J-1.
-!
- CALL DLASWP(j-1,A,Lda,j,j+jb-1,Ipiv,1)
-!
- IF ( j+jb<=N ) THEN
-!
-! Apply interchanges to columns J+JB:N.
-!
- CALL DLASWP(N-j-jb+1,A(1,j+jb),Lda,j,j+jb-1,Ipiv,1)
-!
-! Compute block row of U.
-!
- CALL DTRSM('Left','Lower','No transpose','Unit',jb, &
- & N-j-jb+1,ONE,A(j,j),Lda,A(j,j+jb),Lda)
-!
-! Update trailing submatrix.
-!
- IF ( j+jb<=M ) CALL DGEMM('No transpose','No transpose', &
- & M-j-jb+1,N-j-jb+1,jb,-ONE,A(j+jb,j),Lda,A(j,j+jb), &
- & Lda,ONE,A(j+jb,j+jb),Lda)
- ENDIF
- ENDDO
- ENDIF
-!
-! End of DGETRF
-!
- END SUBROUTINE DGETRF
-!*==DGETRI.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-
-
- SUBROUTINE DGETRI(N,A,Lda,Ipiv,Work,Lwork,Info)
- USE S_DGEMM
- USE S_DGEMV
- USE S_DSWAP
- USE S_DTRSM
- USE S_DTRTRI
- USE S_ILAENV
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - N
-!A OUTPUT - A
-!A INPUT - LDA
-!A INPUT - IPIV
-!A OUTPUT - WORK
-!A INPUT - LWORK
-!A OUTPUT - INFO
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls DGEMM DGEMV DSWAP DTRSM DTRTRI ILAENV
-! XERBLA
-! called by ** NOTHING **
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I IWS J JB JJ JP
-! LDWORK NB NBMIN NN
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ZERO = 0.0D+0 , ONE = 1.0D+0
-!
-! Dummy arguments
-!
- INTEGER :: Info , Lda , Lwork , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- DOUBLE PRECISION , DIMENSION(Lwork) :: Work
- INTENT (IN) Ipiv , Lwork
- INTENT (INOUT) A , Info
-!
-! Local variables
-!
- INTEGER :: i , iws , j , jb , jj , jp , ldwork , nb , nbmin , nn
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! September 30, 1994
-!
-! .. Scalar Arguments ..
-! ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DGETRI computes the inverse of a matrix using the LU factorization
-! computed by DGETRF.
-!
-! This method inverts U and then computes inv(A) by solving the system
-! inv(A)*L = inv(U) for inv(A).
-!
-! Arguments
-! =========
-!
-! N (input) INTEGER
-! The order of the matrix A. N >= 0.
-!
-! A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-! On entry, the factors L and U from the factorization
-! A = P*L*U as computed by DGETRF.
-! On exit, if INFO = 0, the inverse of the original matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,N).
-!
-! IPIV (input) INTEGER array, dimension (N)
-! The pivot indices from DGETRF; for 1<=i<=N, row i of the
-! matrix was interchanged with row IPIV(i).
-!
-! WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
-! On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
-!
-! LWORK (input) INTEGER
-! The dimension of the array WORK. LWORK >= max(1,N).
-! For optimal performance LWORK >= N*NB, where NB is
-! the optimal blocksize returned by ILAENV.
-!
-! INFO (output) INTEGER
-! = 0: successful exit
-! < 0: if INFO = -i, the i-th argument had an illegal value
-! > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
-! singular and its inverse could not be computed.
-!
-! =====================================================================
-!
-! .. Parameters ..
-! ..
-! .. Local Scalars ..
-! ..
-! .. External Functions ..
-! ..
-! .. External Subroutines ..
-! ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- Info = 0
- Work(1) = MAX(N,1)
- IF ( N<0 ) THEN
- Info = -1
- ELSEIF ( Lda<MAX(1,N) ) THEN
- Info = -3
- ELSEIF ( Lwork<MAX(1,N) ) THEN
- Info = -6
- ENDIF
- IF ( Info/=0 ) THEN
- CALL XERBLA('DGETRI',-Info)
- RETURN
- ENDIF
-!
-! Quick return if possible
-!
- IF ( N==0 ) RETURN
-!
-! Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
-! and the inverse is not computed.
-!
- CALL DTRTRI('Upper','Non-unit',N,A,Lda,Info)
- IF ( Info>0 ) RETURN
-!
-! Determine the block size for this environment.
-!
- nb = ILAENV(1,'DGETRI',' ',N,-1,-1,-1)
- nbmin = 2
- ldwork = N
- IF ( nb>1 .AND. nb<N ) THEN
- iws = MAX(ldwork*nb,1)
- IF ( Lwork<iws ) THEN
- nb = Lwork/ldwork
- nbmin = MAX(2,ILAENV(2,'DGETRI',' ',N,-1,-1,-1))
- ENDIF
- ELSE
- iws = N
- ENDIF
-!
-! Solve the equation inv(A)*L = inv(U) for inv(A).
-!
- IF ( nb<nbmin .OR. nb>=N ) THEN
-!
-! Use unblocked code.
-!
- DO j = N , 1 , -1
-!
-! Copy current column of L to WORK and replace with zeros.
-!
- DO i = j + 1 , N
- Work(i) = A(i,j)
- A(i,j) = ZERO
- ENDDO
-!
-! Compute current column of inv(A).
-!
- IF ( j<N ) CALL DGEMV('No transpose',N,N-j,-ONE,A(1,j+1), &
- & Lda,Work(j+1),1,ONE,A(1,j),1)
- ENDDO
- ELSE
-!
-! Use blocked code.
-!
- nn = ((N-1)/nb)*nb + 1
- DO j = nn , 1 , -nb
- jb = MIN(nb,N-j+1)
-!
-! Copy current block column of L to WORK and replace with
-! zeros.
-!
- DO jj = j , j + jb - 1
- DO i = jj + 1 , N
- Work(i+(jj-j)*ldwork) = A(i,jj)
- A(i,jj) = ZERO
- ENDDO
- ENDDO
-!
-! Compute current block column of inv(A).
-!
- IF ( j+jb<=N ) CALL DGEMM('No transpose','No transpose',N, &
- & jb,N-j-jb+1,-ONE,A(1,j+jb),Lda, &
- & Work(j+jb),ldwork,ONE,A(1,j),Lda)
- CALL DTRSM('Right','Lower','No transpose','Unit',N,jb,ONE, &
- & Work(j),ldwork,A(1,j),Lda)
- ENDDO
- ENDIF
-!
-! Apply column interchanges.
-!
- DO j = N - 1 , 1 , -1
- jp = Ipiv(j)
- IF ( jp/=j ) CALL DSWAP(N,A(1,j),1,A(1,jp),1)
- ENDDO
-!
- Work(1) = iws
-!
-! End of DGETRI
-!
- END SUBROUTINE DGETRI
-!*==DLASWP.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-
-
- SUBROUTINE DLASWP(N,A,Lda,K1,K2,Ipiv,Incx)
- USE S_DSWAP
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - N
-!A PASSED - A
-!A INPUT - LDA
-!A INPUT - K1
-!A INPUT - K2
-!A INPUT - IPIV
-!A INPUT - INCX
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls DSWAP
-! called by DGETRF
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I IP IX
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- INTEGER :: Incx , K1 , K2 , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTEGER , DIMENSION(*) :: Ipiv
- INTENT (IN) Incx , Ipiv , K1 , K2
-!
-! Local variables
-!
- INTEGER :: i , ip , ix
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK auxiliary routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! October 31, 1992
-!
-! .. Scalar Arguments ..
-! ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DLASWP performs a series of row interchanges on the matrix A.
-! One row interchange is initiated for each of rows K1 through K2 of A.
-!
-! Arguments
-! =========
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-! On entry, the matrix of column dimension N to which the row
-! interchanges will be applied.
-! On exit, the permuted matrix.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A.
-!
-! K1 (input) INTEGER
-! The first element of IPIV for which a row interchange will
-! be done.
-!
-! K2 (input) INTEGER
-! The last element of IPIV for which a row interchange will
-! be done.
-!
-! IPIV (input) INTEGER array, dimension (M*abs(INCX))
-! The vector of pivot indices. Only the elements in positions
-! K1 through K2 of IPIV are accessed.
-! IPIV(K) = L implies rows K and L are to be interchanged.
-!
-! INCX (input) INTEGER
-! The increment between successive values of IPIV. If IPIV
-! is negative, the pivots are applied in reverse order.
-!
-! =====================================================================
-!
-! .. Local Scalars ..
-! ..
-! .. External Subroutines ..
-! ..
-! .. Executable Statements ..
-!
-! Interchange row I with row IPIV(I) for each of rows K1 through K2.
-!
- IF ( Incx==0 ) RETURN
- IF ( Incx>0 ) THEN
- ix = K1
- ELSE
- ix = 1 + (1-K2)*Incx
- ENDIF
- IF ( Incx==1 ) THEN
- DO i = K1 , K2
- ip = Ipiv(i)
- IF ( ip/=i ) CALL DSWAP(N,A(i,1),Lda,A(ip,1),Lda)
- ENDDO
- ELSEIF ( Incx>1 ) THEN
- DO i = K1 , K2
- ip = Ipiv(ix)
- IF ( ip/=i ) CALL DSWAP(N,A(i,1),Lda,A(ip,1),Lda)
- ix = ix + Incx
- ENDDO
- ELSEIF ( Incx<0 ) THEN
- DO i = K2 , K1 , -1
- ip = Ipiv(ix)
- IF ( ip/=i ) CALL DSWAP(N,A(i,1),Lda,A(ip,1),Lda)
- ix = ix + Incx
- ENDDO
- ENDIF
-!
-!
-! End of DLASWP
-!
- END SUBROUTINE DLASWP
-!*==DTRTI2.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-
-
- SUBROUTINE DTRTI2(Uplo,Diag,N,A,Lda,Info)
- USE S_DSCAL
- USE S_DTRMV
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - UPLO
-!A PASSED - DIAG
-!A INPUT - N
-!A OUTPUT - A
-!A INPUT - LDA
-!A OUTPUT - INFO
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls DSCAL DTRMV LSAME XERBLA
-! called by DTRTRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars AJJ J NOUNIT UPPER
-! uses PARAMs ONE
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0
-!
-! Dummy arguments
-!
- CHARACTER :: Diag , Uplo
- INTEGER :: Info , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTENT (IN) N
- INTENT (INOUT) A , Info
-!
-! Local variables
-!
- DOUBLE PRECISION :: ajj
- INTEGER :: j
- LOGICAL :: nounit , upper
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! February 29, 1992
-!
-! .. Scalar Arguments ..
-! ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DTRTI2 computes the inverse of a real upper or lower triangular
-! matrix.
-!
-! This is the Level 2 BLAS version of the algorithm.
-!
-! Arguments
-! =========
-!
-! UPLO (input) CHARACTER*1
-! Specifies whether the matrix A is upper or lower triangular.
-! = 'U': Upper triangular
-! = 'L': Lower triangular
-!
-! DIAG (input) CHARACTER*1
-! Specifies whether or not the matrix A is unit triangular.
-! = 'N': Non-unit triangular
-! = 'U': Unit triangular
-!
-! N (input) INTEGER
-! The order of the matrix A. N >= 0.
-!
-! A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-! On entry, the triangular matrix A. If UPLO = 'U', the
-! leading n by n upper triangular part of the array A contains
-! the upper triangular matrix, and the strictly lower
-! triangular part of A is not referenced. If UPLO = 'L', the
-! leading n by n lower triangular part of the array A contains
-! the lower triangular matrix, and the strictly upper
-! triangular part of A is not referenced. If DIAG = 'U', the
-! diagonal elements of A are also not referenced and are
-! assumed to be 1.
-!
-! On exit, the (triangular) inverse of the original matrix, in
-! the same storage format.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,N).
-!
-! INFO (output) INTEGER
-! = 0: successful exit
-! < 0: if INFO = -k, the k-th argument had an illegal value
-!
-! =====================================================================
-!
-! .. Parameters ..
-! ..
-! .. Local Scalars ..
-! ..
-! .. External Functions ..
-! ..
-! .. External Subroutines ..
-! ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- Info = 0
- upper = LSAME(Uplo,'U')
- nounit = LSAME(Diag,'N')
- IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
- Info = -1
- ELSEIF ( .NOT.nounit .AND. .NOT.LSAME(Diag,'U') ) THEN
- Info = -2
- ELSEIF ( N<0 ) THEN
- Info = -3
- ELSEIF ( Lda<MAX(1,N) ) THEN
- Info = -5
- ENDIF
- IF ( Info/=0 ) THEN
- CALL XERBLA('DTRTI2',-Info)
- RETURN
- ENDIF
-!
- IF ( upper ) THEN
-!
-! Compute inverse of upper triangular matrix.
-!
- DO j = 1 , N
- IF ( nounit ) THEN
- A(j,j) = ONE/A(j,j)
- ajj = -A(j,j)
- ELSE
- ajj = -ONE
- ENDIF
-!
-! Compute elements 1:j-1 of j-th column.
-!
- CALL DTRMV('Upper','No transpose',Diag,j-1,A,Lda,A(1,j),1)
- CALL DSCAL(j-1,ajj,A(1,j),1)
- ENDDO
- ELSE
-!
-! Compute inverse of lower triangular matrix.
-!
- DO j = N , 1 , -1
- IF ( nounit ) THEN
- A(j,j) = ONE/A(j,j)
- ajj = -A(j,j)
- ELSE
- ajj = -ONE
- ENDIF
- IF ( j<N ) THEN
-!
-! Compute elements j+1:n of j-th column.
-!
- CALL DTRMV('Lower','No transpose',Diag,N-j,A(j+1,j+1), &
- & Lda,A(j+1,j),1)
- CALL DSCAL(N-j,ajj,A(j+1,j),1)
- ENDIF
- ENDDO
- ENDIF
-!
-!
-! End of DTRTI2
-!
- END SUBROUTINE DTRTI2
-!*==DTRTRI.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-
-
- SUBROUTINE DTRTRI(Uplo,Diag,N,A,Lda,Info)
- USE S_DTRMM
- USE S_DTRSM
- USE S_DTRTI2
- USE S_ILAENV
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - UPLO
-!A INPUT - DIAG
-!A INPUT - N
-!A INPUT - A
-!A INPUT - LDA
-!A OUTPUT - INFO
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls DTRMM DTRSM DTRTI2 ILAENV LSAME XERBLA
-! called by DGETRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars J JB NB NN NOUNIT UPPER
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- CHARACTER :: Diag , Uplo
- INTEGER :: Info , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- INTENT (INOUT) Info
-!
-! Local variables
-!
- INTEGER :: j , jb , nb , nn
- LOGICAL :: nounit , upper
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! March 31, 1993
-!
-! .. Scalar Arguments ..
-! ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DTRTRI computes the inverse of a real upper or lower triangular
-! matrix A.
-!
-! This is the Level 3 BLAS version of the algorithm.
-!
-! Arguments
-! =========
-!
-! UPLO (input) CHARACTER*1
-! = 'U': A is upper triangular;
-! = 'L': A is lower triangular.
-!
-! DIAG (input) CHARACTER*1
-! = 'N': A is non-unit triangular;
-! = 'U': A is unit triangular.
-!
-! N (input) INTEGER
-! The order of the matrix A. N >= 0.
-!
-! A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
-! On entry, the triangular matrix A. If UPLO = 'U', the
-! leading N-by-N upper triangular part of the array A contains
-! the upper triangular matrix, and the strictly lower
-! triangular part of A is not referenced. If UPLO = 'L', the
-! leading N-by-N lower triangular part of the array A contains
-! the lower triangular matrix, and the strictly upper
-! triangular part of A is not referenced. If DIAG = 'U', the
-! diagonal elements of A are also not referenced and are
-! assumed to be 1.
-! On exit, the (triangular) inverse of the original matrix, in
-! the same storage format.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,N).
-!
-! INFO (output) INTEGER
-! = 0: successful exit
-! < 0: if INFO = -i, the i-th argument had an illegal value
-! > 0: if INFO = i, A(i,i) is exactly zero. The triangular
-! matrix is singular and its inverse can not be computed.
-!
-! =====================================================================
-!
-! .. Parameters ..
-! ..
-! .. Local Scalars ..
-! ..
-! .. External Functions ..
-! ..
-! .. External Subroutines ..
-! ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- Info = 0
- upper = LSAME(Uplo,'U')
- nounit = LSAME(Diag,'N')
- IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
- Info = -1
- ELSEIF ( .NOT.nounit .AND. .NOT.LSAME(Diag,'U') ) THEN
- Info = -2
- ELSEIF ( N<0 ) THEN
- Info = -3
- ELSEIF ( Lda<MAX(1,N) ) THEN
- Info = -5
- ENDIF
- IF ( Info/=0 ) THEN
- CALL XERBLA('DTRTRI',-Info)
- RETURN
- ENDIF
-!
-! Quick return if possible
-!
- IF ( N==0 ) RETURN
-!
-! Check for singularity if non-unit.
-!
- IF ( nounit ) THEN
- DO Info = 1 , N
- IF ( A(Info,Info)==ZERO ) RETURN
- ENDDO
- Info = 0
- ENDIF
-!
-! Determine the block size for this environment.
-!
- nb = ILAENV(1,'DTRTRI',Uplo//Diag,N,-1,-1,-1)
- IF ( nb<=1 .OR. nb>=N ) THEN
-!
-! Use unblocked code
-!
- CALL DTRTI2(Uplo,Diag,N,A,Lda,Info)
-!
-! Use blocked code
-!
- ELSEIF ( upper ) THEN
-!
-! Compute inverse of upper triangular matrix
-!
- DO j = 1 , N , nb
- jb = MIN(nb,N-j+1)
-!
-! Compute rows 1:j-1 of current block column
-!
- CALL DTRMM('Left','Upper','No transpose',Diag,j-1,jb,ONE,A, &
- & Lda,A(1,j),Lda)
- CALL DTRSM('Right','Upper','No transpose',Diag,j-1,jb,-ONE, &
- & A(j,j),Lda,A(1,j),Lda)
-!
-! Compute inverse of current diagonal block
-!
- CALL DTRTI2('Upper',Diag,jb,A(j,j),Lda,Info)
- ENDDO
- ELSE
-!
-! Compute inverse of lower triangular matrix
-!
- nn = ((N-1)/nb)*nb + 1
- DO j = nn , 1 , -nb
- jb = MIN(nb,N-j+1)
- IF ( j+jb<=N ) THEN
-!
-! Compute rows j+jb:n of current block column
-!
- CALL DTRMM('Left','Lower','No transpose',Diag,N-j-jb+1, &
- & jb,ONE,A(j+jb,j+jb),Lda,A(j+jb,j),Lda)
- CALL DTRSM('Right','Lower','No transpose',Diag,N-j-jb+1, &
- & jb,-ONE,A(j,j),Lda,A(j+jb,j),Lda)
- ENDIF
-!
-! Compute inverse of current diagonal block
-!
- CALL DTRTI2('Lower',Diag,jb,A(j,j),Lda,Info)
- ENDDO
- ENDIF
-!
-!
-! End of DTRTRI
-!
- END SUBROUTINE DTRTRI
-!*==ILAENV.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- FUNCTION ILAENV(Ispec,Name,Opts,N1,N2,N3,N4)
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - ISPEC
-!A INPUT - NAME
-!A UNUSED - OPTS
-!A INPUT - N1
-!A INPUT - N2
-!A UNUSED - N3
-!A INPUT - N4
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls ** NOTHING **
-! called by DGETRF DGETRI DTRTRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars C1 C2 C3 C4 CNAME I IC
-! IZ NB NBMIN NX SNAME SUBNAM
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- INTEGER :: Ispec , N1 , N2 , N3 , N4
- CHARACTER(*) :: Name , Opts
- INTEGER :: ILAENV
- INTENT (IN) Ispec , N1 , N2 , N4 , Name
-!
-! Local variables
-!
- CHARACTER(1) :: c1
- CHARACTER(2) :: c2 , c4
- CHARACTER(3) :: c3
- LOGICAL :: cname , sname
- INTEGER :: i , ic , iz , nb , nbmin , nx
- CHARACTER(6) :: subnam
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK auxiliary routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! September 30, 1994
-!
-! .. Scalar Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! ILAENV is called from the LAPACK routines to choose problem-dependent
-! parameters for the local environment. See ISPEC for a description of
-! the parameters.
-!
-! This version provides a set of parameters which should give good,
-! but not optimal, performance on many of the currently available
-! computers. Users are encouraged to modify this subroutine to set
-! the tuning parameters for their particular machine using the option
-! and problem size information in the arguments.
-!
-! This routine will not function correctly if it is converted to all
-! lower case. Converting it to all upper case is allowed.
-!
-! Arguments
-! =========
-!
-! ISPEC (input) INTEGER
-! Specifies the parameter to be returned as the value of
-! ILAENV.
-! = 1: the optimal blocksize; if this value is 1, an unblocked
-! algorithm will give the best performance.
-! = 2: the minimum block size for which the block routine
-! should be used; if the usable block size is less than
-! this value, an unblocked routine should be used.
-! = 3: the crossover point (in a block routine, for N less
-! than this value, an unblocked routine should be used)
-! = 4: the number of shifts, used in the nonsymmetric
-! eigenvalue routines
-! = 5: the minimum column dimension for blocking to be used;
-! rectangular blocks must have dimension at least k by m,
-! where k is given by ILAENV(2,...) and m by ILAENV(5,...)
-! = 6: the crossover point for the SVD (when reducing an m by n
-! matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
-! this value, a QR factorization is used first to reduce
-! the matrix to a triangular form.)
-! = 7: the number of processors
-! = 8: the crossover point for the multishift QR and QZ methods
-! for nonsymmetric eigenvalue problems.
-!
-! NAME (input) CHARACTER*(*)
-! The name of the calling subroutine, in either upper case or
-! lower case.
-!
-! OPTS (input) CHARACTER*(*)
-! The character options to the subroutine NAME, concatenated
-! into a single character string. For example, UPLO = 'U',
-! TRANS = 'T', and DIAG = 'N' for a triangular routine would
-! be specified as OPTS = 'UTN'.
-!
-! N1 (input) INTEGER
-! N2 (input) INTEGER
-! N3 (input) INTEGER
-! N4 (input) INTEGER
-! Problem dimensions for the subroutine NAME; these may not all
-! be required.
-!
-! (ILAENV) (output) INTEGER
-! >= 0: the value of the parameter specified by ISPEC
-! < 0: if ILAENV = -k, the k-th argument had an illegal value.
-!
-! Further Details
-! ===============
-!
-! The following conventions have been used when calling ILAENV from the
-! LAPACK routines:
-! 1) OPTS is a concatenation of all of the character options to
-! subroutine NAME, in the same order that they appear in the
-! argument list for NAME, even if they are not used in determining
-! the value of the parameter specified by ISPEC.
-! 2) The problem dimensions N1, N2, N3, N4 are specified in the order
-! that they appear in the argument list for NAME. N1 is used
-! first, N2 second, and so on, and unused problem dimensions are
-! passed a value of -1.
-! 3) The parameter value returned by ILAENV is checked for validity in
-! the calling subroutine. For example, ILAENV is used to retrieve
-! the optimal blocksize for STRTRI as follows:
-!
-! NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
-! IF( NB.LE.1 ) NB = MAX( 1, N )
-!
-! =====================================================================
-!
-! .. Local Scalars ..
-! ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
- SELECT CASE (Ispec)
- CASE (1,2,3)
-!
-!
-! Convert NAME to upper case if the first character is lower case.
-!
- ILAENV = 1
- subnam = Name
- ic = ICHAR(subnam(1:1))
- iz = ICHAR('Z')
- IF ( iz==90 .OR. iz==122 ) THEN
-!
-! ASCII character set
-!
- IF ( ic>=97 .AND. ic<=122 ) THEN
- subnam(1:1) = CHAR(ic-32)
- DO i = 2 , 6
- ic = ICHAR(subnam(i:i))
- IF ( ic>=97 .AND. ic<=122 ) subnam(i:i) = CHAR(ic-32)
- ENDDO
- ENDIF
-!
- ELSEIF ( iz==233 .OR. iz==169 ) THEN
-!
-! EBCDIC character set
-!
- IF ( (ic>=129 .AND. ic<=137) .OR. (ic>=145 .AND. ic<=153) &
- & .OR. (ic>=162 .AND. ic<=169) ) THEN
- subnam(1:1) = CHAR(ic+64)
- DO i = 2 , 6
- ic = ICHAR(subnam(i:i))
- IF ( (ic>=129 .AND. ic<=137) .OR. &
- & (ic>=145 .AND. ic<=153) .OR. &
- & (ic>=162 .AND. ic<=169) ) subnam(i:i) &
- & = CHAR(ic+64)
- ENDDO
- ENDIF
-!
- ELSEIF ( iz==218 .OR. iz==250 ) THEN
-!
-! Prime machines: ASCII+128
-!
- IF ( ic>=225 .AND. ic<=250 ) THEN
- subnam(1:1) = CHAR(ic-32)
- DO i = 2 , 6
- ic = ICHAR(subnam(i:i))
- IF ( ic>=225 .AND. ic<=250 ) subnam(i:i) = CHAR(ic-32)
- ENDDO
- ENDIF
- ENDIF
-!
- c1 = subnam(1:1)
- sname = c1=='S' .OR. c1=='D'
- cname = c1=='C' .OR. c1=='Z'
- IF ( .NOT.(cname .OR. sname) ) RETURN
- c2 = subnam(2:3)
- c3 = subnam(4:6)
- c4 = c3(2:3)
-!
- SELECT CASE (Ispec)
- CASE (2)
-!
-!
-! ISPEC = 2: minimum block size
-!
- nbmin = 2
- IF ( c2=='GE' ) THEN
- IF ( c3=='QRF' .OR. c3=='RQF' .OR. c3=='LQF' .OR. &
- & c3=='QLF' ) THEN
- IF ( sname ) THEN
- nbmin = 2
- ELSE
- nbmin = 2
- ENDIF
- ELSEIF ( c3=='HRD' ) THEN
- IF ( sname ) THEN
- nbmin = 2
- ELSE
- nbmin = 2
- ENDIF
- ELSEIF ( c3=='BRD' ) THEN
- IF ( sname ) THEN
- nbmin = 2
- ELSE
- nbmin = 2
- ENDIF
- ELSEIF ( c3=='TRI' ) THEN
- IF ( sname ) THEN
- nbmin = 2
- ELSE
- nbmin = 2
- ENDIF
- ENDIF
- ELSEIF ( c2=='SY' ) THEN
- IF ( c3=='TRF' ) THEN
- IF ( sname ) THEN
- nbmin = 8
- ELSE
- nbmin = 8
- ENDIF
- ELSEIF ( sname .AND. c3=='TRD' ) THEN
- nbmin = 2
- ENDIF
- ELSEIF ( cname .AND. c2=='HE' ) THEN
- IF ( c3=='TRD' ) nbmin = 2
- ELSEIF ( sname .AND. c2=='OR' ) THEN
- IF ( c3(1:1)=='G' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nbmin = 2
- ELSEIF ( c3(1:1)=='M' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nbmin = 2
- ENDIF
- ELSEIF ( cname .AND. c2=='UN' ) THEN
- IF ( c3(1:1)=='G' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nbmin = 2
- ELSEIF ( c3(1:1)=='M' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nbmin = 2
- ENDIF
- ENDIF
- ILAENV = nbmin
- RETURN
- CASE (3)
-!
-!
-! ISPEC = 3: crossover point
-!
- nx = 0
- IF ( c2=='GE' ) THEN
- IF ( c3=='QRF' .OR. c3=='RQF' .OR. c3=='LQF' .OR. &
- & c3=='QLF' ) THEN
- IF ( sname ) THEN
- nx = 128
- ELSE
- nx = 128
- ENDIF
- ELSEIF ( c3=='HRD' ) THEN
- IF ( sname ) THEN
- nx = 128
- ELSE
- nx = 128
- ENDIF
- ELSEIF ( c3=='BRD' ) THEN
- IF ( sname ) THEN
- nx = 128
- ELSE
- nx = 128
- ENDIF
- ENDIF
- ELSEIF ( c2=='SY' ) THEN
- IF ( sname .AND. c3=='TRD' ) nx = 1
- ELSEIF ( cname .AND. c2=='HE' ) THEN
- IF ( c3=='TRD' ) nx = 1
- ELSEIF ( sname .AND. c2=='OR' ) THEN
- IF ( c3(1:1)=='G' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nx = 128
- ENDIF
- ELSEIF ( cname .AND. c2=='UN' ) THEN
- IF ( c3(1:1)=='G' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nx = 128
- ENDIF
- ENDIF
- ILAENV = nx
- RETURN
- CASE DEFAULT
-!
-!
-! ISPEC = 1: block size
-!
-! In these examples, separate code is provided for setting NB for
-! real and complex. We assume that NB will take the same value in
-! single or double precision.
-!
- nb = 1
-!
- IF ( c2=='GE' ) THEN
- IF ( c3=='TRF' ) THEN
- IF ( sname ) THEN
- nb = 64
- ELSE
- nb = 64
- ENDIF
- ELSEIF ( c3=='QRF' .OR. c3=='RQF' .OR. c3=='LQF' .OR. &
- & c3=='QLF' ) THEN
- IF ( sname ) THEN
- nb = 32
- ELSE
- nb = 32
- ENDIF
- ELSEIF ( c3=='HRD' ) THEN
- IF ( sname ) THEN
- nb = 32
- ELSE
- nb = 32
- ENDIF
- ELSEIF ( c3=='BRD' ) THEN
- IF ( sname ) THEN
- nb = 32
- ELSE
- nb = 32
- ENDIF
- ELSEIF ( c3=='TRI' ) THEN
- IF ( sname ) THEN
- nb = 64
- ELSE
- nb = 64
- ENDIF
- ENDIF
- ELSEIF ( c2=='PO' ) THEN
- IF ( c3=='TRF' ) THEN
- IF ( sname ) THEN
- nb = 64
- ELSE
- nb = 64
- ENDIF
- ENDIF
- ELSEIF ( c2=='SY' ) THEN
- IF ( c3=='TRF' ) THEN
- IF ( sname ) THEN
- nb = 64
- ELSE
- nb = 64
- ENDIF
- ELSEIF ( sname .AND. c3=='TRD' ) THEN
- nb = 1
- ELSEIF ( sname .AND. c3=='GST' ) THEN
- nb = 64
- ENDIF
- ELSEIF ( cname .AND. c2=='HE' ) THEN
- IF ( c3=='TRF' ) THEN
- nb = 64
- ELSEIF ( c3=='TRD' ) THEN
- nb = 1
- ELSEIF ( c3=='GST' ) THEN
- nb = 64
- ENDIF
- ELSEIF ( sname .AND. c2=='OR' ) THEN
- IF ( c3(1:1)=='G' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nb = 32
- ELSEIF ( c3(1:1)=='M' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nb = 32
- ENDIF
- ELSEIF ( cname .AND. c2=='UN' ) THEN
- IF ( c3(1:1)=='G' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nb = 32
- ELSEIF ( c3(1:1)=='M' ) THEN
- IF ( c4=='QR' .OR. c4=='RQ' .OR. c4=='LQ' .OR. &
- & c4=='QL' .OR. c4=='HR' .OR. c4=='TR' .OR. &
- & c4=='BR' ) nb = 32
- ENDIF
- ELSEIF ( c2=='GB' ) THEN
- IF ( c3=='TRF' ) THEN
- IF ( sname ) THEN
- IF ( N4<=64 ) THEN
- nb = 1
- ELSE
- nb = 32
- ENDIF
- ELSEIF ( N4<=64 ) THEN
- nb = 1
- ELSE
- nb = 32
- ENDIF
- ENDIF
- ELSEIF ( c2=='PB' ) THEN
- IF ( c3=='TRF' ) THEN
- IF ( sname ) THEN
- IF ( N2<=64 ) THEN
- nb = 1
- ELSE
- nb = 32
- ENDIF
- ELSEIF ( N2<=64 ) THEN
- nb = 1
- ELSE
- nb = 32
- ENDIF
- ENDIF
- ELSEIF ( c2=='TR' ) THEN
- IF ( c3=='TRI' ) THEN
- IF ( sname ) THEN
- nb = 64
- ELSE
- nb = 64
- ENDIF
- ENDIF
- ELSEIF ( c2=='LA' ) THEN
- IF ( c3=='UUM' ) THEN
- IF ( sname ) THEN
- nb = 64
- ELSE
- nb = 64
- ENDIF
- ENDIF
- ELSEIF ( sname .AND. c2=='ST' ) THEN
- IF ( c3=='EBZ' ) nb = 1
- ENDIF
-!** Reduce NB ??? !!!
- ILAENV = nb
- ! max (NB/2, 1) ???
- RETURN
- END SELECT
- CASE (4)
-!
-!
-! ISPEC = 4: number of shifts (used by xHSEQR)
-!
- ILAENV = 6
- RETURN
- CASE (5)
-!
-!
-! ISPEC = 5: minimum column dimension (not used)
-!
- ILAENV = 2
- RETURN
- CASE (6)
-!
-!
-! ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
-!
- ILAENV = INT(REAL(MIN(N1,N2))*1.6E0)
- RETURN
- CASE (7)
-!
-!
-! ISPEC = 7: number of processors (not used)
-!
- ILAENV = 1
- RETURN
- CASE (8)
-!
-!
-! ISPEC = 8: crossover point for multishift (used by xHSEQR)
-!
- ILAENV = 50
- GOTO 99999
- CASE DEFAULT
- END SELECT
-!
-! Invalid value for ISPEC
-!
- ILAENV = -1
- RETURN
-!
-! End of ILAENV
-!
-99999 END FUNCTION ILAENV
-!*==LSAME.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- FUNCTION LSAME(Ca,Cb)
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - CA
-!A INPUT - CB
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls ** NOTHING **
-! called by DGEMM DGEMV DTRMM DTRMV DTRSM DTRTI2
-! DTRTRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars INTA INTB ZCODE
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- CHARACTER :: Ca , Cb
- LOGICAL :: LSAME
- INTENT (IN) Ca , Cb
-!
-! Local variables
-!
- INTEGER :: inta , intb , zcode
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK auxiliary routine (version 2.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! September 30, 1994
-!
-! .. Scalar Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! LSAME returns .TRUE. if CA is the same letter as CB regardless of
-! case.
-!
-! Arguments
-! =========
-!
-! CA (input) CHARACTER*1
-! CB (input) CHARACTER*1
-! CA and CB specify the single characters to be compared.
-!
-! =====================================================================
-!
-! .. Intrinsic Functions ..
-! ..
-! .. Local Scalars ..
-! ..
-! .. Executable Statements ..
-!
-! Test if the characters are equal
-!
- LSAME = Ca==Cb
- IF ( LSAME ) RETURN
-!
-! Now test for equivalence if both characters are alphabetic.
-!
- zcode = ICHAR('Z')
-!
-! Use 'Z' rather than 'A' so that ASCII can be detected on Prime
-! machines, on which ICHAR returns a value with bit 8 set.
-! ICHAR('A') on Prime machines returns 193 which is the same as
-! ICHAR('A') on an EBCDIC machine.
-!
- inta = ICHAR(Ca)
- intb = ICHAR(Cb)
-!
- IF ( zcode==90 .OR. zcode==122 ) THEN
-!
-! ASCII is assumed - ZCODE is the ASCII code of either lower or
-! upper case 'Z'.
-!
- IF ( inta>=97 .AND. inta<=122 ) inta = inta - 32
- IF ( intb>=97 .AND. intb<=122 ) intb = intb - 32
-!
- ELSEIF ( zcode==233 .OR. zcode==169 ) THEN
-!
-! EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
-! upper case 'Z'.
-!
- IF ( inta>=129 .AND. inta<=137 .OR. inta>=145 .AND. &
- & inta<=153 .OR. inta>=162 .AND. inta<=169 ) inta = inta + &
- & 64
- IF ( intb>=129 .AND. intb<=137 .OR. intb>=145 .AND. &
- & intb<=153 .OR. intb>=162 .AND. intb<=169 ) intb = intb + &
- & 64
-!
- ELSEIF ( zcode==218 .OR. zcode==250 ) THEN
-!
-! ASCII is assumed, on Prime machines - ZCODE is the ASCII code
-! plus 128 of either lower or upper case 'Z'.
-!
- IF ( inta>=225 .AND. inta<=250 ) inta = inta - 32
- IF ( intb>=225 .AND. intb<=250 ) intb = intb - 32
- ENDIF
- LSAME = inta==intb
-!
-! RETURN
-!
-! End of LSAME
-!
- END FUNCTION LSAME
-!*==DGEMM.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
-!****************************************************************************
-! This file contains the BLAS routines that are called by LAPACK routines
-! for inversion of a matrix. The Lapack routines (NOT in this file!) are:
-! dgetf2 dgetrf dgetri dlaswp dtrti2 dtrtri ilaenv lsame
-!
-! The BLAS routines (in this file) are:
-! dgemm dger dswap dtrmv idamax
-! dgemv dscal dtrmm dtrsm xerbla
-!
-! Instead of these routines you can better use a processor-optimized
-! library (like INTEL mkl library).
-!
-! J. Bergervoet
-! May, 1998
-!****************************************************************************
-
- SUBROUTINE DGEMM(Transa,Transb,M,N,K,Alpha,A,Lda,B,Ldb,Beta,C,Ldc)
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - TRANSA
-!A PASSED - TRANSB
-!A INPUT - M
-!A INPUT - N
-!A INPUT - K
-!A INPUT - ALPHA
-!A INPUT - A
-!A INPUT - LDA
-!A INPUT - B
-!A INPUT - LDB
-!A INPUT - BETA
-!A OUTPUT - C
-!A INPUT - LDC
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls LSAME XERBLA
-! called by DGETRF DGETRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I INFO J L NCOLA NOTA
-! NOTB NROWA NROWB TEMP
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- DOUBLE PRECISION :: Alpha , Beta
- INTEGER :: K , Lda , Ldb , Ldc , M , N
- CHARACTER(1) :: Transa , Transb
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(Ldb,*) :: B
- DOUBLE PRECISION , DIMENSION(Ldc,*) :: C
- INTENT (IN) A , Alpha , B , Beta , K , Lda , Ldb , Ldc , M , N
- INTENT (INOUT) C
-!
-! Local variables
-!
- INTEGER :: i , info , j , l , ncola , nrowa , nrowb
- LOGICAL :: nota , notb
- DOUBLE PRECISION :: temp
-!
-!*** End of declarations rewritten by SPAG
-!
-! .. Scalar Arguments ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DGEMM performs one of the matrix-matrix operations
-!
-! C := alpha*op( A )*op( B ) + beta*C,
-!
-! where op( X ) is one of
-!
-! op( X ) = X or op( X ) = X',
-!
-! alpha and beta are scalars, and A, B and C are matrices, with op( A )
-! an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
-!
-! Parameters
-! ==========
-!
-! TRANSA - CHARACTER*1.
-! On entry, TRANSA specifies the form of op( A ) to be used in
-! the matrix multiplication as follows:
-!
-! TRANSA = 'N' or 'n', op( A ) = A.
-!
-! TRANSA = 'T' or 't', op( A ) = A'.
-!
-! TRANSA = 'C' or 'c', op( A ) = A'.
-!
-! Unchanged on exit.
-!
-! TRANSB - CHARACTER*1.
-! On entry, TRANSB specifies the form of op( B ) to be used in
-! the matrix multiplication as follows:
-!
-! TRANSB = 'N' or 'n', op( B ) = B.
-!
-! TRANSB = 'T' or 't', op( B ) = B'.
-!
-! TRANSB = 'C' or 'c', op( B ) = B'.
-!
-! Unchanged on exit.
-!
-! M - INTEGER.
-! On entry, M specifies the number of rows of the matrix
-! op( A ) and of the matrix C. M must be at least zero.
-! Unchanged on exit.
-!
-! N - INTEGER.
-! On entry, N specifies the number of columns of the matrix
-! op( B ) and the number of columns of the matrix C. N must be
-! at least zero.
-! Unchanged on exit.
-!
-! K - INTEGER.
-! On entry, K specifies the number of columns of the matrix
-! op( A ) and the number of rows of the matrix op( B ). K must
-! be at least zero.
-! Unchanged on exit.
-!
-! ALPHA - DOUBLE PRECISION.
-! On entry, ALPHA specifies the scalar alpha.
-! Unchanged on exit.
-!
-! A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
-! k when TRANSA = 'N' or 'n', and is m otherwise.
-! Before entry with TRANSA = 'N' or 'n', the leading m by k
-! part of the array A must contain the matrix A, otherwise
-! the leading k by m part of the array A must contain the
-! matrix A.
-! Unchanged on exit.
-!
-! LDA - INTEGER.
-! On entry, LDA specifies the first dimension of A as declared
-! in the calling (sub) program. When TRANSA = 'N' or 'n' then
-! LDA must be at least max( 1, m ), otherwise LDA must be at
-! least max( 1, k ).
-! Unchanged on exit.
-!
-! B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
-! n when TRANSB = 'N' or 'n', and is k otherwise.
-! Before entry with TRANSB = 'N' or 'n', the leading k by n
-! part of the array B must contain the matrix B, otherwise
-! the leading n by k part of the array B must contain the
-! matrix B.
-! Unchanged on exit.
-!
-! LDB - INTEGER.
-! On entry, LDB specifies the first dimension of B as declared
-! in the calling (sub) program. When TRANSB = 'N' or 'n' then
-! LDB must be at least max( 1, k ), otherwise LDB must be at
-! least max( 1, n ).
-! Unchanged on exit.
-!
-! BETA - DOUBLE PRECISION.
-! On entry, BETA specifies the scalar beta. When BETA is
-! supplied as zero then C need not be set on input.
-! Unchanged on exit.
-!
-! C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
-! Before entry, the leading m by n part of the array C must
-! contain the matrix C, except when beta is zero, in which
-! case C need not be set on entry.
-! On exit, the array C is overwritten by the m by n matrix
-! ( alpha*op( A )*op( B ) + beta*C ).
-!
-! LDC - INTEGER.
-! On entry, LDC specifies the first dimension of C as declared
-! in the calling (sub) program. LDC must be at least
-! max( 1, m ).
-! Unchanged on exit.
-!
-!
-! Level 3 Blas routine.
-!
-! -- Written on 8-February-1989.
-! Jack Dongarra, Argonne National Laboratory.
-! Iain Duff, AERE Harwell.
-! Jeremy Du Croz, Numerical Algorithms Group Ltd.
-! Sven Hammarling, Numerical Algorithms Group Ltd.
-!
-!
-! .. External Functions ..
-! .. External Subroutines ..
-! .. Intrinsic Functions ..
-! .. Local Scalars ..
-! .. Parameters ..
-! ..
-! .. Executable Statements ..
-!
-! Set NOTA and NOTB as true if A and B respectively are not
-! transposed and set NROWA, NCOLA and NROWB as the number of rows
-! and columns of A and the number of rows of B respectively.
-!
- nota = LSAME(Transa,'N')
- notb = LSAME(Transb,'N')
- IF ( nota ) THEN
- nrowa = M
- ncola = K
- ELSE
- nrowa = K
- ncola = M
- ENDIF
- IF ( notb ) THEN
- nrowb = K
- ELSE
- nrowb = N
- ENDIF
-!
-! Test the input parameters.
-!
- info = 0
- IF ( (.NOT.nota) .AND. (.NOT.LSAME(Transa,'C')) .AND. &
- & (.NOT.LSAME(Transa,'T')) ) THEN
- info = 1
- ELSEIF ( (.NOT.notb) .AND. (.NOT.LSAME(Transb,'C')) .AND. &
- & (.NOT.LSAME(Transb,'T')) ) THEN
- info = 2
- ELSEIF ( M<0 ) THEN
- info = 3
- ELSEIF ( N<0 ) THEN
- info = 4
- ELSEIF ( K<0 ) THEN
- info = 5
- ELSEIF ( Lda<MAX(1,nrowa) ) THEN
- info = 8
- ELSEIF ( Ldb<MAX(1,nrowb) ) THEN
- info = 10
- ELSEIF ( Ldc<MAX(1,M) ) THEN
- info = 13
- ENDIF
- IF ( info/=0 ) THEN
- CALL XERBLA('DGEMM ',info)
- RETURN
- ENDIF
-!
-! Quick return if possible.
-!
- IF ( (M==0) .OR. (N==0) .OR. &
- & (((Alpha==ZERO) .OR. (K==0)) .AND. (Beta==ONE)) ) RETURN
-!
-! And if alpha.eq.zero.
-!
- IF ( Alpha==ZERO ) THEN
- IF ( Beta==ZERO ) THEN
- DO j = 1 , N
- DO i = 1 , M
- C(i,j) = ZERO
- ENDDO
- ENDDO
- ELSE
- DO j = 1 , N
- DO i = 1 , M
- C(i,j) = Beta*C(i,j)
- ENDDO
- ENDDO
- ENDIF
- RETURN
- ENDIF
-!
-! Start the operations.
-!
- IF ( notb ) THEN
- IF ( nota ) THEN
-!
-! Form C := alpha*A*B + beta*C.
-!
- DO j = 1 , N
- IF ( Beta==ZERO ) THEN
- DO i = 1 , M
- C(i,j) = ZERO
- ENDDO
- ELSEIF ( Beta/=ONE ) THEN
- DO i = 1 , M
- C(i,j) = Beta*C(i,j)
- ENDDO
- ENDIF
- DO l = 1 , K
- IF ( B(l,j)/=ZERO ) THEN
- temp = Alpha*B(l,j)
- DO i = 1 , M
- C(i,j) = C(i,j) + temp*A(i,l)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ELSE
-!
-! Form C := alpha*A'*B + beta*C
-!
- DO j = 1 , N
- DO i = 1 , M
- temp = ZERO
- DO l = 1 , K
- temp = temp + A(l,i)*B(l,j)
- ENDDO
- IF ( Beta==ZERO ) THEN
- C(i,j) = Alpha*temp
- ELSE
- C(i,j) = Alpha*temp + Beta*C(i,j)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
- ELSEIF ( nota ) THEN
-!
-! Form C := alpha*A*B' + beta*C
-!
- DO j = 1 , N
- IF ( Beta==ZERO ) THEN
- DO i = 1 , M
- C(i,j) = ZERO
- ENDDO
- ELSEIF ( Beta/=ONE ) THEN
- DO i = 1 , M
- C(i,j) = Beta*C(i,j)
- ENDDO
- ENDIF
- DO l = 1 , K
- IF ( B(j,l)/=ZERO ) THEN
- temp = Alpha*B(j,l)
- DO i = 1 , M
- C(i,j) = C(i,j) + temp*A(i,l)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ELSE
-!
-! Form C := alpha*A'*B' + beta*C
-!
- DO j = 1 , N
- DO i = 1 , M
- temp = ZERO
- DO l = 1 , K
- temp = temp + A(l,i)*B(j,l)
- ENDDO
- IF ( Beta==ZERO ) THEN
- C(i,j) = Alpha*temp
- ELSE
- C(i,j) = Alpha*temp + Beta*C(i,j)
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-!
-! End of DGEMM .
-!
- END SUBROUTINE DGEMM
-!*==DGEMV.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DGEMV(Trans,M,N,Alpha,A,Lda,X,Incx,Beta,Y,Incy)
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - TRANS
-!A INPUT - M
-!A INPUT - N
-!A INPUT - ALPHA
-!A INPUT - A
-!A INPUT - LDA
-!A INPUT - X
-!A INPUT - INCX
-!A INPUT - BETA
-!A OUTPUT - Y
-!A INPUT - INCY
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls LSAME XERBLA
-! called by DGETRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I INFO IX IY J JX JY
-! KX KY LENX LENY TEMP
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- DOUBLE PRECISION :: Alpha , Beta
- INTEGER :: Incx , Incy , Lda , M , N
- CHARACTER(1) :: Trans
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(*) :: X , Y
- INTENT (IN) A , Alpha , Beta , Incx , Incy , Lda , M , N , X
- INTENT (INOUT) Y
-!
-! Local variables
-!
- INTEGER :: i , info , ix , iy , j , jx , jy , kx , ky , lenx , &
- & leny
- DOUBLE PRECISION :: temp
-!
-!*** End of declarations rewritten by SPAG
-!
-! .. Scalar Arguments ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DGEMV performs one of the matrix-vector operations
-!
-! y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
-!
-! where alpha and beta are scalars, x and y are vectors and A is an
-! m by n matrix.
-!
-! Parameters
-! ==========
-!
-! TRANS - CHARACTER*1.
-! On entry, TRANS specifies the operation to be performed as
-! follows:
-!
-! TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
-!
-! TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
-!
-! TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
-!
-! Unchanged on exit.
-!
-! M - INTEGER.
-! On entry, M specifies the number of rows of the matrix A.
-! M must be at least zero.
-! Unchanged on exit.
-!
-! N - INTEGER.
-! On entry, N specifies the number of columns of the matrix A.
-! N must be at least zero.
-! Unchanged on exit.
-!
-! ALPHA - DOUBLE PRECISION.
-! On entry, ALPHA specifies the scalar alpha.
-! Unchanged on exit.
-!
-! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
-! Before entry, the leading m by n part of the array A must
-! contain the matrix of coefficients.
-! Unchanged on exit.
-!
-! LDA - INTEGER.
-! On entry, LDA specifies the first dimension of A as declared
-! in the calling (sub) program. LDA must be at least
-! max( 1, m ).
-! Unchanged on exit.
-!
-! X - DOUBLE PRECISION array of DIMENSION at least
-! ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
-! and at least
-! ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
-! Before entry, the incremented array X must contain the
-! vector x.
-! Unchanged on exit.
-!
-! INCX - INTEGER.
-! On entry, INCX specifies the increment for the elements of
-! X. INCX must not be zero.
-! Unchanged on exit.
-!
-! BETA - DOUBLE PRECISION.
-! On entry, BETA specifies the scalar beta. When BETA is
-! supplied as zero then Y need not be set on input.
-! Unchanged on exit.
-!
-! Y - DOUBLE PRECISION array of DIMENSION at least
-! ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
-! and at least
-! ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
-! Before entry with BETA non-zero, the incremented array Y
-! must contain the vector y. On exit, Y is overwritten by the
-! updated vector y.
-!
-! INCY - INTEGER.
-! On entry, INCY specifies the increment for the elements of
-! Y. INCY must not be zero.
-! Unchanged on exit.
-!
-!
-! Level 2 Blas routine.
-!
-! -- Written on 22-October-1986.
-! Jack Dongarra, Argonne National Lab.
-! Jeremy Du Croz, Nag Central Office.
-! Sven Hammarling, Nag Central Office.
-! Richard Hanson, Sandia National Labs.
-!
-!
-! .. Parameters ..
-! .. Local Scalars ..
-! .. External Functions ..
-! .. External Subroutines ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- info = 0
- IF ( .NOT.LSAME(Trans,'N') .AND. .NOT.LSAME(Trans,'T') .AND. &
- & .NOT.LSAME(Trans,'C') ) THEN
- info = 1
- ELSEIF ( M<0 ) THEN
- info = 2
- ELSEIF ( N<0 ) THEN
- info = 3
- ELSEIF ( Lda<MAX(1,M) ) THEN
- info = 6
- ELSEIF ( Incx==0 ) THEN
- info = 8
- ELSEIF ( Incy==0 ) THEN
- info = 11
- ENDIF
- IF ( info/=0 ) THEN
- CALL XERBLA('DGEMV ',info)
- RETURN
- ENDIF
-!
-! Quick return if possible.
-!
- IF ( (M==0) .OR. (N==0) .OR. ((Alpha==ZERO) .AND. (Beta==ONE)) ) &
- & RETURN
-!
-! Set LENX and LENY, the lengths of the vectors x and y, and set
-! up the start points in X and Y.
-!
- IF ( LSAME(Trans,'N') ) THEN
- lenx = N
- leny = M
- ELSE
- lenx = M
- leny = N
- ENDIF
- IF ( Incx>0 ) THEN
- kx = 1
- ELSE
- kx = 1 - (lenx-1)*Incx
- ENDIF
- IF ( Incy>0 ) THEN
- ky = 1
- ELSE
- ky = 1 - (leny-1)*Incy
- ENDIF
-!
-! Start the operations. In this version the elements of A are
-! accessed sequentially with one pass through A.
-!
-! First form y := beta*y.
-!
- IF ( Beta/=ONE ) THEN
- IF ( Incy/=1 ) THEN
- iy = ky
- IF ( Beta==ZERO ) THEN
- DO i = 1 , leny
- Y(iy) = ZERO
- iy = iy + Incy
- ENDDO
- ELSE
- DO i = 1 , leny
- Y(iy) = Beta*Y(iy)
- iy = iy + Incy
- ENDDO
- ENDIF
- ELSEIF ( Beta==ZERO ) THEN
- DO i = 1 , leny
- Y(i) = ZERO
- ENDDO
- ELSE
- DO i = 1 , leny
- Y(i) = Beta*Y(i)
- ENDDO
- ENDIF
- ENDIF
- IF ( Alpha==ZERO ) RETURN
- IF ( LSAME(Trans,'N') ) THEN
-!
-! Form y := alpha*A*x + y.
-!
- jx = kx
- IF ( Incy==1 ) THEN
- DO j = 1 , N
- IF ( X(jx)/=ZERO ) THEN
- temp = Alpha*X(jx)
- DO i = 1 , M
- Y(i) = Y(i) + temp*A(i,j)
- ENDDO
- ENDIF
- jx = jx + Incx
- ENDDO
- ELSE
- DO j = 1 , N
- IF ( X(jx)/=ZERO ) THEN
- temp = Alpha*X(jx)
- iy = ky
- DO i = 1 , M
- Y(iy) = Y(iy) + temp*A(i,j)
- iy = iy + Incy
- ENDDO
- ENDIF
- jx = jx + Incx
- ENDDO
- ENDIF
- ELSE
-!
-! Form y := alpha*A'*x + y.
-!
- jy = ky
- IF ( Incx==1 ) THEN
- DO j = 1 , N
- temp = ZERO
- DO i = 1 , M
- temp = temp + A(i,j)*X(i)
- ENDDO
- Y(jy) = Y(jy) + Alpha*temp
- jy = jy + Incy
- ENDDO
- ELSE
- DO j = 1 , N
- temp = ZERO
- ix = kx
- DO i = 1 , M
- temp = temp + A(i,j)*X(ix)
- ix = ix + Incx
- ENDDO
- Y(jy) = Y(jy) + Alpha*temp
- jy = jy + Incy
- ENDDO
- ENDIF
- ENDIF
-!
-!
-! End of DGEMV .
-!
- END SUBROUTINE DGEMV
-!*==DGER.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DGER(M,N,Alpha,X,Incx,Y,Incy,A,Lda)
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - M
-!A INPUT - N
-!A INPUT - ALPHA
-!A INPUT - X
-!A INPUT - INCX
-!A INPUT - Y
-!A INPUT - INCY
-!A OUTPUT - A
-!A INPUT - LDA
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls XERBLA
-! called by DGETF2
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I INFO IX J JY KX
-! TEMP
-! uses PARAMs ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- DOUBLE PRECISION :: Alpha
- INTEGER :: Incx , Incy , Lda , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(*) :: X , Y
- INTENT (IN) Alpha , Incx , Incy , Lda , M , N , X , Y
- INTENT (INOUT) A
-!
-! Local variables
-!
- INTEGER :: i , info , ix , j , jy , kx
- DOUBLE PRECISION :: temp
-!
-!*** End of declarations rewritten by SPAG
-!
-! .. Scalar Arguments ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DGER performs the rank 1 operation
-!
-! A := alpha*x*y' + A,
-!
-! where alpha is a scalar, x is an m element vector, y is an n element
-! vector and A is an m by n matrix.
-!
-! Parameters
-! ==========
-!
-! M - INTEGER.
-! On entry, M specifies the number of rows of the matrix A.
-! M must be at least zero.
-! Unchanged on exit.
-!
-! N - INTEGER.
-! On entry, N specifies the number of columns of the matrix A.
-! N must be at least zero.
-! Unchanged on exit.
-!
-! ALPHA - DOUBLE PRECISION.
-! On entry, ALPHA specifies the scalar alpha.
-! Unchanged on exit.
-!
-! X - DOUBLE PRECISION array of dimension at least
-! ( 1 + ( m - 1 )*abs( INCX ) ).
-! Before entry, the incremented array X must contain the m
-! element vector x.
-! Unchanged on exit.
-!
-! INCX - INTEGER.
-! On entry, INCX specifies the increment for the elements of
-! X. INCX must not be zero.
-! Unchanged on exit.
-!
-! Y - DOUBLE PRECISION array of dimension at least
-! ( 1 + ( n - 1 )*abs( INCY ) ).
-! Before entry, the incremented array Y must contain the n
-! element vector y.
-! Unchanged on exit.
-!
-! INCY - INTEGER.
-! On entry, INCY specifies the increment for the elements of
-! Y. INCY must not be zero.
-! Unchanged on exit.
-!
-! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
-! Before entry, the leading m by n part of the array A must
-! contain the matrix of coefficients. On exit, A is
-! overwritten by the updated matrix.
-!
-! LDA - INTEGER.
-! On entry, LDA specifies the first dimension of A as declared
-! in the calling (sub) program. LDA must be at least
-! max( 1, m ).
-! Unchanged on exit.
-!
-!
-! Level 2 Blas routine.
-!
-! -- Written on 22-October-1986.
-! Jack Dongarra, Argonne National Lab.
-! Jeremy Du Croz, Nag Central Office.
-! Sven Hammarling, Nag Central Office.
-! Richard Hanson, Sandia National Labs.
-!
-!
-! .. Parameters ..
-! .. Local Scalars ..
-! .. External Subroutines ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- info = 0
- IF ( M<0 ) THEN
- info = 1
- ELSEIF ( N<0 ) THEN
- info = 2
- ELSEIF ( Incx==0 ) THEN
- info = 5
- ELSEIF ( Incy==0 ) THEN
- info = 7
- ELSEIF ( Lda<MAX(1,M) ) THEN
- info = 9
- ENDIF
- IF ( info/=0 ) THEN
- CALL XERBLA('DGER ',info)
- RETURN
- ENDIF
-!
-! Quick return if possible.
-!
- IF ( (M==0) .OR. (N==0) .OR. (Alpha==ZERO) ) RETURN
-!
-! Start the operations. In this version the elements of A are
-! accessed sequentially with one pass through A.
-!
- IF ( Incy>0 ) THEN
- jy = 1
- ELSE
- jy = 1 - (N-1)*Incy
- ENDIF
- IF ( Incx==1 ) THEN
- DO j = 1 , N
- IF ( Y(jy)/=ZERO ) THEN
- temp = Alpha*Y(jy)
- DO i = 1 , M
- A(i,j) = A(i,j) + X(i)*temp
- ENDDO
- ENDIF
- jy = jy + Incy
- ENDDO
- ELSE
- IF ( Incx>0 ) THEN
- kx = 1
- ELSE
- kx = 1 - (M-1)*Incx
- ENDIF
- DO j = 1 , N
- IF ( Y(jy)/=ZERO ) THEN
- temp = Alpha*Y(jy)
- ix = kx
- DO i = 1 , M
- A(i,j) = A(i,j) + X(ix)*temp
- ix = ix + Incx
- ENDDO
- ENDIF
- jy = jy + Incy
- ENDDO
- ENDIF
-!
-!
-! End of DGER .
-!
- END SUBROUTINE DGER
-!*==DSCAL.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DSCAL(N,Da,Dx,Incx)
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - N
-!A INPUT - DA
-!A OUTPUT - DX
-!A INPUT - INCX
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls ** NOTHING **
-! called by DGETF2 DTRTI2
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I M MP1 NINCX
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- DOUBLE PRECISION :: Da
- INTEGER :: Incx , N
- DOUBLE PRECISION , DIMENSION(*) :: Dx
- INTENT (IN) Da , Incx , N
- INTENT (INOUT) Dx
-!
-! Local variables
-!
- INTEGER :: i , m , mp1 , nincx
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! scales a vector by a constant.
-! uses unrolled loops for increment equal to one.
-! jack dongarra, linpack, 3/11/78.
-! modified 3/93 to return if incx .le. 0.
-! modified 12/3/93, array(1) declarations changed to array(*)
-!
-!
- IF ( N<=0 .OR. Incx<=0 ) RETURN
- IF ( Incx==1 ) THEN
-!
-! code for increment equal to 1
-!
-!
-! clean-up loop
-!
- m = MOD(N,5)
- IF ( m/=0 ) THEN
- DO i = 1 , m
- Dx(i) = Da*Dx(i)
- ENDDO
- IF ( N<5 ) RETURN
- ENDIF
- mp1 = m + 1
- DO i = mp1 , N , 5
- Dx(i) = Da*Dx(i)
- Dx(i+1) = Da*Dx(i+1)
- Dx(i+2) = Da*Dx(i+2)
- Dx(i+3) = Da*Dx(i+3)
- Dx(i+4) = Da*Dx(i+4)
- ENDDO
- ELSE
-!
-! code for increment not equal to 1
-!
- nincx = N*Incx
- DO i = 1 , nincx , Incx
- Dx(i) = Da*Dx(i)
- ENDDO
- RETURN
- ENDIF
- END SUBROUTINE DSCAL
-!*==DSWAP.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DSWAP(N,Dx,Incx,Dy,Incy)
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - N
-!A OUTPUT - DX
-!A INPUT - INCX
-!A OUTPUT - DY
-!A INPUT - INCY
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls ** NOTHING **
-! called by DGETF2 DGETRI DLASWP
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars DTEMP I IX IY M MP1
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- INTEGER :: Incx , Incy , N
- DOUBLE PRECISION , DIMENSION(*) :: Dx , Dy
- INTENT (IN) Incx , Incy , N
- INTENT (INOUT) Dx , Dy
-!
-! Local variables
-!
- DOUBLE PRECISION :: dtemp
- INTEGER :: i , ix , iy , m , mp1
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! interchanges two vectors.
-! uses unrolled loops for increments equal one.
-! jack dongarra, linpack, 3/11/78.
-! modified 12/3/93, array(1) declarations changed to array(*)
-!
-!
- IF ( N<=0 ) RETURN
- IF ( Incx==1 .AND. Incy==1 ) THEN
-!
-! code for both increments equal to 1
-!
-!
-! clean-up loop
-!
- m = MOD(N,3)
- IF ( m/=0 ) THEN
- DO i = 1 , m
- dtemp = Dx(i)
- Dx(i) = Dy(i)
- Dy(i) = dtemp
- ENDDO
- IF ( N<3 ) RETURN
- ENDIF
- mp1 = m + 1
- DO i = mp1 , N , 3
- dtemp = Dx(i)
- Dx(i) = Dy(i)
- Dy(i) = dtemp
- dtemp = Dx(i+1)
- Dx(i+1) = Dy(i+1)
- Dy(i+1) = dtemp
- dtemp = Dx(i+2)
- Dx(i+2) = Dy(i+2)
- Dy(i+2) = dtemp
- ENDDO
- ELSE
-!
-! code for unequal increments or equal increments not equal
-! to 1
-!
- ix = 1
- iy = 1
- IF ( Incx<0 ) ix = (-N+1)*Incx + 1
- IF ( Incy<0 ) iy = (-N+1)*Incy + 1
- DO i = 1 , N
- dtemp = Dx(ix)
- Dx(ix) = Dy(iy)
- Dy(iy) = dtemp
- ix = ix + Incx
- iy = iy + Incy
- ENDDO
- RETURN
- ENDIF
- END SUBROUTINE DSWAP
-!*==DTRMM.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DTRMM(Side,Uplo,Transa,Diag,M,N,Alpha,A,Lda,B,Ldb)
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - SIDE
-!A PASSED - UPLO
-!A PASSED - TRANSA
-!A PASSED - DIAG
-!A INPUT - M
-!A INPUT - N
-!A INPUT - ALPHA
-!A INPUT - A
-!A INPUT - LDA
-!A OUTPUT - B
-!A INPUT - LDB
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls LSAME XERBLA
-! called by DTRTRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I INFO J K LSIDE NOUNIT
-! NROWA TEMP UPPER
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- DOUBLE PRECISION :: Alpha
- CHARACTER(1) :: Diag , Side , Transa , Uplo
- INTEGER :: Lda , Ldb , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(Ldb,*) :: B
- INTENT (IN) A , Alpha , Lda , Ldb , M , N
- INTENT (INOUT) B
-!
-! Local variables
-!
- INTEGER :: i , info , j , k , nrowa
- LOGICAL :: lside , nounit , upper
- DOUBLE PRECISION :: temp
-!
-!*** End of declarations rewritten by SPAG
-!
-! .. Scalar Arguments ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DTRMM performs one of the matrix-matrix operations
-!
-! B := alpha*op( A )*B, or B := alpha*B*op( A ),
-!
-! where alpha is a scalar, B is an m by n matrix, A is a unit, or
-! non-unit, upper or lower triangular matrix and op( A ) is one of
-!
-! op( A ) = A or op( A ) = A'.
-!
-! Parameters
-! ==========
-!
-! SIDE - CHARACTER*1.
-! On entry, SIDE specifies whether op( A ) multiplies B from
-! the left or right as follows:
-!
-! SIDE = 'L' or 'l' B := alpha*op( A )*B.
-!
-! SIDE = 'R' or 'r' B := alpha*B*op( A ).
-!
-! Unchanged on exit.
-!
-! UPLO - CHARACTER*1.
-! On entry, UPLO specifies whether the matrix A is an upper or
-! lower triangular matrix as follows:
-!
-! UPLO = 'U' or 'u' A is an upper triangular matrix.
-!
-! UPLO = 'L' or 'l' A is a lower triangular matrix.
-!
-! Unchanged on exit.
-!
-! TRANSA - CHARACTER*1.
-! On entry, TRANSA specifies the form of op( A ) to be used in
-! the matrix multiplication as follows:
-!
-! TRANSA = 'N' or 'n' op( A ) = A.
-!
-! TRANSA = 'T' or 't' op( A ) = A'.
-!
-! TRANSA = 'C' or 'c' op( A ) = A'.
-!
-! Unchanged on exit.
-!
-! DIAG - CHARACTER*1.
-! On entry, DIAG specifies whether or not A is unit triangular
-! as follows:
-!
-! DIAG = 'U' or 'u' A is assumed to be unit triangular.
-!
-! DIAG = 'N' or 'n' A is not assumed to be unit
-! triangular.
-!
-! Unchanged on exit.
-!
-! M - INTEGER.
-! On entry, M specifies the number of rows of B. M must be at
-! least zero.
-! Unchanged on exit.
-!
-! N - INTEGER.
-! On entry, N specifies the number of columns of B. N must be
-! at least zero.
-! Unchanged on exit.
-!
-! ALPHA - DOUBLE PRECISION.
-! On entry, ALPHA specifies the scalar alpha. When alpha is
-! zero then A is not referenced and B need not be set before
-! entry.
-! Unchanged on exit.
-!
-! A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
-! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
-! Before entry with UPLO = 'U' or 'u', the leading k by k
-! upper triangular part of the array A must contain the upper
-! triangular matrix and the strictly lower triangular part of
-! A is not referenced.
-! Before entry with UPLO = 'L' or 'l', the leading k by k
-! lower triangular part of the array A must contain the lower
-! triangular matrix and the strictly upper triangular part of
-! A is not referenced.
-! Note that when DIAG = 'U' or 'u', the diagonal elements of
-! A are not referenced either, but are assumed to be unity.
-! Unchanged on exit.
-!
-! LDA - INTEGER.
-! On entry, LDA specifies the first dimension of A as declared
-! in the calling (sub) program. When SIDE = 'L' or 'l' then
-! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
-! then LDA must be at least max( 1, n ).
-! Unchanged on exit.
-!
-! B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
-! Before entry, the leading m by n part of the array B must
-! contain the matrix B, and on exit is overwritten by the
-! transformed matrix.
-!
-! LDB - INTEGER.
-! On entry, LDB specifies the first dimension of B as declared
-! in the calling (sub) program. LDB must be at least
-! max( 1, m ).
-! Unchanged on exit.
-!
-!
-! Level 3 Blas routine.
-!
-! -- Written on 8-February-1989.
-! Jack Dongarra, Argonne National Laboratory.
-! Iain Duff, AERE Harwell.
-! Jeremy Du Croz, Numerical Algorithms Group Ltd.
-! Sven Hammarling, Numerical Algorithms Group Ltd.
-!
-!
-! .. External Functions ..
-! .. External Subroutines ..
-! .. Intrinsic Functions ..
-! .. Local Scalars ..
-! .. Parameters ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- lside = LSAME(Side,'L')
- IF ( lside ) THEN
- nrowa = M
- ELSE
- nrowa = N
- ENDIF
- nounit = LSAME(Diag,'N')
- upper = LSAME(Uplo,'U')
-!
- info = 0
- IF ( (.NOT.lside) .AND. (.NOT.LSAME(Side,'R')) ) THEN
- info = 1
- ELSEIF ( (.NOT.upper) .AND. (.NOT.LSAME(Uplo,'L')) ) THEN
- info = 2
- ELSEIF ( (.NOT.LSAME(Transa,'N')) .AND. (.NOT.LSAME(Transa,'T')) &
- & .AND. (.NOT.LSAME(Transa,'C')) ) THEN
- info = 3
- ELSEIF ( (.NOT.LSAME(Diag,'U')) .AND. (.NOT.LSAME(Diag,'N')) ) &
- & THEN
- info = 4
- ELSEIF ( M<0 ) THEN
- info = 5
- ELSEIF ( N<0 ) THEN
- info = 6
- ELSEIF ( Lda<MAX(1,nrowa) ) THEN
- info = 9
- ELSEIF ( Ldb<MAX(1,M) ) THEN
- info = 11
- ENDIF
- IF ( info/=0 ) THEN
- CALL XERBLA('DTRMM ',info)
- RETURN
- ENDIF
-!
-! Quick return if possible.
-!
- IF ( N==0 ) RETURN
-!
-! And when alpha.eq.zero.
-!
- IF ( Alpha==ZERO ) THEN
- DO j = 1 , N
- DO i = 1 , M
- B(i,j) = ZERO
- ENDDO
- ENDDO
- RETURN
- ENDIF
-!
-! Start the operations.
-!
- IF ( lside ) THEN
- IF ( LSAME(Transa,'N') ) THEN
-!
-! Form B := alpha*A*B.
-!
- IF ( upper ) THEN
- DO j = 1 , N
- DO k = 1 , M
- IF ( B(k,j)/=ZERO ) THEN
- temp = Alpha*B(k,j)
- DO i = 1 , k - 1
- B(i,j) = B(i,j) + temp*A(i,k)
- ENDDO
- IF ( nounit ) temp = temp*A(k,k)
- B(k,j) = temp
- ENDIF
- ENDDO
- ENDDO
- ELSE
- DO j = 1 , N
- DO k = M , 1 , -1
- IF ( B(k,j)/=ZERO ) THEN
- temp = Alpha*B(k,j)
- B(k,j) = temp
- IF ( nounit ) B(k,j) = B(k,j)*A(k,k)
- DO i = k + 1 , M
- B(i,j) = B(i,j) + temp*A(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-! Form B := alpha*B*A'.
-!
- ELSEIF ( upper ) THEN
- DO j = 1 , N
- DO i = M , 1 , -1
- temp = B(i,j)
- IF ( nounit ) temp = temp*A(i,i)
- DO k = 1 , i - 1
- temp = temp + A(k,i)*B(k,j)
- ENDDO
- B(i,j) = Alpha*temp
- ENDDO
- ENDDO
- ELSE
- DO j = 1 , N
- DO i = 1 , M
- temp = B(i,j)
- IF ( nounit ) temp = temp*A(i,i)
- DO k = i + 1 , M
- temp = temp + A(k,i)*B(k,j)
- ENDDO
- B(i,j) = Alpha*temp
- ENDDO
- ENDDO
- ENDIF
- ELSEIF ( LSAME(Transa,'N') ) THEN
-!
-! Form B := alpha*B*A.
-!
- IF ( upper ) THEN
- DO j = N , 1 , -1
- temp = Alpha
- IF ( nounit ) temp = temp*A(j,j)
- DO i = 1 , M
- B(i,j) = temp*B(i,j)
- ENDDO
- DO k = 1 , j - 1
- IF ( A(k,j)/=ZERO ) THEN
- temp = Alpha*A(k,j)
- DO i = 1 , M
- B(i,j) = B(i,j) + temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ELSE
- DO j = 1 , N
- temp = Alpha
- IF ( nounit ) temp = temp*A(j,j)
- DO i = 1 , M
- B(i,j) = temp*B(i,j)
- ENDDO
- DO k = j + 1 , N
- IF ( A(k,j)/=ZERO ) THEN
- temp = Alpha*A(k,j)
- DO i = 1 , M
- B(i,j) = B(i,j) + temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-! Form B := alpha*B*A'.
-!
- ELSEIF ( upper ) THEN
- DO k = 1 , N
- DO j = 1 , k - 1
- IF ( A(j,k)/=ZERO ) THEN
- temp = Alpha*A(j,k)
- DO i = 1 , M
- B(i,j) = B(i,j) + temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- temp = Alpha
- IF ( nounit ) temp = temp*A(k,k)
- IF ( temp/=ONE ) THEN
- DO i = 1 , M
- B(i,k) = temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- ELSE
- DO k = N , 1 , -1
- DO j = k + 1 , N
- IF ( A(j,k)/=ZERO ) THEN
- temp = Alpha*A(j,k)
- DO i = 1 , M
- B(i,j) = B(i,j) + temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- temp = Alpha
- IF ( nounit ) temp = temp*A(k,k)
- IF ( temp/=ONE ) THEN
- DO i = 1 , M
- B(i,k) = temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-!
-!
-! End of DTRMM .
-!
- END SUBROUTINE DTRMM
-!*==DTRMV.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DTRMV(Uplo,Trans,Diag,N,A,Lda,X,Incx)
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - UPLO
-!A PASSED - TRANS
-!A PASSED - DIAG
-!A INPUT - N
-!A INPUT - A
-!A INPUT - LDA
-!A OUTPUT - X
-!A INPUT - INCX
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls LSAME XERBLA
-! called by DTRTI2
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I INFO IX J JX KX
-! NOUNIT TEMP
-! uses PARAMs ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- CHARACTER(1) :: Diag , Trans , Uplo
- INTEGER :: Incx , Lda , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(*) :: X
- INTENT (IN) A , Incx , Lda , N
- INTENT (INOUT) X
-!
-! Local variables
-!
- INTEGER :: i , info , ix , j , jx , kx
- LOGICAL :: nounit
- DOUBLE PRECISION :: temp
-!
-!*** End of declarations rewritten by SPAG
-!
-! .. Scalar Arguments ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DTRMV performs one of the matrix-vector operations
-!
-! x := A*x, or x := A'*x,
-!
-! where x is an n element vector and A is an n by n unit, or non-unit,
-! upper or lower triangular matrix.
-!
-! Parameters
-! ==========
-!
-! UPLO - CHARACTER*1.
-! On entry, UPLO specifies whether the matrix is an upper or
-! lower triangular matrix as follows:
-!
-! UPLO = 'U' or 'u' A is an upper triangular matrix.
-!
-! UPLO = 'L' or 'l' A is a lower triangular matrix.
-!
-! Unchanged on exit.
-!
-! TRANS - CHARACTER*1.
-! On entry, TRANS specifies the operation to be performed as
-! follows:
-!
-! TRANS = 'N' or 'n' x := A*x.
-!
-! TRANS = 'T' or 't' x := A'*x.
-!
-! TRANS = 'C' or 'c' x := A'*x.
-!
-! Unchanged on exit.
-!
-! DIAG - CHARACTER*1.
-! On entry, DIAG specifies whether or not A is unit
-! triangular as follows:
-!
-! DIAG = 'U' or 'u' A is assumed to be unit triangular.
-!
-! DIAG = 'N' or 'n' A is not assumed to be unit
-! triangular.
-!
-! Unchanged on exit.
-!
-! N - INTEGER.
-! On entry, N specifies the order of the matrix A.
-! N must be at least zero.
-! Unchanged on exit.
-!
-! A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
-! Before entry with UPLO = 'U' or 'u', the leading n by n
-! upper triangular part of the array A must contain the upper
-! triangular matrix and the strictly lower triangular part of
-! A is not referenced.
-! Before entry with UPLO = 'L' or 'l', the leading n by n
-! lower triangular part of the array A must contain the lower
-! triangular matrix and the strictly upper triangular part of
-! A is not referenced.
-! Note that when DIAG = 'U' or 'u', the diagonal elements of
-! A are not referenced either, but are assumed to be unity.
-! Unchanged on exit.
-!
-! LDA - INTEGER.
-! On entry, LDA specifies the first dimension of A as declared
-! in the calling (sub) program. LDA must be at least
-! max( 1, n ).
-! Unchanged on exit.
-!
-! X - DOUBLE PRECISION array of dimension at least
-! ( 1 + ( n - 1 )*abs( INCX ) ).
-! Before entry, the incremented array X must contain the n
-! element vector x. On exit, X is overwritten with the
-! tranformed vector x.
-!
-! INCX - INTEGER.
-! On entry, INCX specifies the increment for the elements of
-! X. INCX must not be zero.
-! Unchanged on exit.
-!
-!
-! Level 2 Blas routine.
-!
-! -- Written on 22-October-1986.
-! Jack Dongarra, Argonne National Lab.
-! Jeremy Du Croz, Nag Central Office.
-! Sven Hammarling, Nag Central Office.
-! Richard Hanson, Sandia National Labs.
-!
-!
-! .. Parameters ..
-! .. Local Scalars ..
-! .. External Functions ..
-! .. External Subroutines ..
-! .. Intrinsic Functions ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- info = 0
- IF ( .NOT.LSAME(Uplo,'U') .AND. .NOT.LSAME(Uplo,'L') ) THEN
- info = 1
- ELSEIF ( .NOT.LSAME(Trans,'N') .AND. .NOT.LSAME(Trans,'T') .AND. &
- & .NOT.LSAME(Trans,'C') ) THEN
- info = 2
- ELSEIF ( .NOT.LSAME(Diag,'U') .AND. .NOT.LSAME(Diag,'N') ) THEN
- info = 3
- ELSEIF ( N<0 ) THEN
- info = 4
- ELSEIF ( Lda<MAX(1,N) ) THEN
- info = 6
- ELSEIF ( Incx==0 ) THEN
- info = 8
- ENDIF
- IF ( info/=0 ) THEN
- CALL XERBLA('DTRMV ',info)
- RETURN
- ENDIF
-!
-! Quick return if possible.
-!
- IF ( N==0 ) RETURN
-!
- nounit = LSAME(Diag,'N')
-!
-! Set up the start point in X if the increment is not unity. This
-! will be ( N - 1 )*INCX too small for descending loops.
-!
- IF ( Incx<=0 ) THEN
- kx = 1 - (N-1)*Incx
- ELSEIF ( Incx/=1 ) THEN
- kx = 1
- ENDIF
-!
-! Start the operations. In this version the elements of A are
-! accessed sequentially with one pass through A.
-!
- IF ( LSAME(Trans,'N') ) THEN
-!
-! Form x := A*x.
-!
- IF ( LSAME(Uplo,'U') ) THEN
- IF ( Incx==1 ) THEN
- DO j = 1 , N
- IF ( X(j)/=ZERO ) THEN
- temp = X(j)
- DO i = 1 , j - 1
- X(i) = X(i) + temp*A(i,j)
- ENDDO
- IF ( nounit ) X(j) = X(j)*A(j,j)
- ENDIF
- ENDDO
- ELSE
- jx = kx
- DO j = 1 , N
- IF ( X(jx)/=ZERO ) THEN
- temp = X(jx)
- ix = kx
- DO i = 1 , j - 1
- X(ix) = X(ix) + temp*A(i,j)
- ix = ix + Incx
- ENDDO
- IF ( nounit ) X(jx) = X(jx)*A(j,j)
- ENDIF
- jx = jx + Incx
- ENDDO
- ENDIF
- ELSEIF ( Incx==1 ) THEN
- DO j = N , 1 , -1
- IF ( X(j)/=ZERO ) THEN
- temp = X(j)
- DO i = N , j + 1 , -1
- X(i) = X(i) + temp*A(i,j)
- ENDDO
- IF ( nounit ) X(j) = X(j)*A(j,j)
- ENDIF
- ENDDO
- ELSE
- kx = kx + (N-1)*Incx
- jx = kx
- DO j = N , 1 , -1
- IF ( X(jx)/=ZERO ) THEN
- temp = X(jx)
- ix = kx
- DO i = N , j + 1 , -1
- X(ix) = X(ix) + temp*A(i,j)
- ix = ix - Incx
- ENDDO
- IF ( nounit ) X(jx) = X(jx)*A(j,j)
- ENDIF
- jx = jx - Incx
- ENDDO
- ENDIF
-!
-! Form x := A'*x.
-!
- ELSEIF ( LSAME(Uplo,'U') ) THEN
- IF ( Incx==1 ) THEN
- DO j = N , 1 , -1
- temp = X(j)
- IF ( nounit ) temp = temp*A(j,j)
- DO i = j - 1 , 1 , -1
- temp = temp + A(i,j)*X(i)
- ENDDO
- X(j) = temp
- ENDDO
- ELSE
- jx = kx + (N-1)*Incx
- DO j = N , 1 , -1
- temp = X(jx)
- ix = jx
- IF ( nounit ) temp = temp*A(j,j)
- DO i = j - 1 , 1 , -1
- ix = ix - Incx
- temp = temp + A(i,j)*X(ix)
- ENDDO
- X(jx) = temp
- jx = jx - Incx
- ENDDO
- ENDIF
- ELSEIF ( Incx==1 ) THEN
- DO j = 1 , N
- temp = X(j)
- IF ( nounit ) temp = temp*A(j,j)
- DO i = j + 1 , N
- temp = temp + A(i,j)*X(i)
- ENDDO
- X(j) = temp
- ENDDO
- ELSE
- jx = kx
- DO j = 1 , N
- temp = X(jx)
- ix = jx
- IF ( nounit ) temp = temp*A(j,j)
- DO i = j + 1 , N
- ix = ix + Incx
- temp = temp + A(i,j)*X(ix)
- ENDDO
- X(jx) = temp
- jx = jx + Incx
- ENDDO
- ENDIF
-!
-!
-! End of DTRMV .
-!
- END SUBROUTINE DTRMV
-!*==DTRSM.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE DTRSM(Side,Uplo,Transa,Diag,M,N,Alpha,A,Lda,B,Ldb)
- USE S_LSAME
- USE S_XERBLA
- IMPLICIT NONE
-!*--********************************************************************
-!A PASSED - SIDE
-!A PASSED - UPLO
-!A PASSED - TRANSA
-!A PASSED - DIAG
-!A INPUT - M
-!A INPUT - N
-!A INPUT - ALPHA
-!A INPUT - A
-!A INPUT - LDA
-!A OUTPUT - B
-!A INPUT - LDB
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls LSAME XERBLA
-! called by DGETRF DGETRI DTRTRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars I INFO J K LSIDE NOUNIT
-! NROWA TEMP UPPER
-! uses PARAMs ONE ZERO
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! PARAMETER definitions
-!
- DOUBLE PRECISION , PARAMETER :: ONE = 1.0D+0 , ZERO = 0.0D+0
-!
-! Dummy arguments
-!
- DOUBLE PRECISION :: Alpha
- CHARACTER(1) :: Diag , Side , Transa , Uplo
- INTEGER :: Lda , Ldb , M , N
- DOUBLE PRECISION , DIMENSION(Lda,*) :: A
- DOUBLE PRECISION , DIMENSION(Ldb,*) :: B
- INTENT (IN) A , Alpha , Lda , Ldb , M , N
- INTENT (INOUT) B
-!
-! Local variables
-!
- INTEGER :: i , info , j , k , nrowa
- LOGICAL :: lside , nounit , upper
- DOUBLE PRECISION :: temp
-!
-!*** End of declarations rewritten by SPAG
-!
-! .. Scalar Arguments ..
-! .. Array Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! DTRSM solves one of the matrix equations
-!
-! op( A )*X = alpha*B, or X*op( A ) = alpha*B,
-!
-! where alpha is a scalar, X and B are m by n matrices, A is a unit, or
-! non-unit, upper or lower triangular matrix and op( A ) is one of
-!
-! op( A ) = A or op( A ) = A'.
-!
-! The matrix X is overwritten on B.
-!
-! Parameters
-! ==========
-!
-! SIDE - CHARACTER*1.
-! On entry, SIDE specifies whether op( A ) appears on the left
-! or right of X as follows:
-!
-! SIDE = 'L' or 'l' op( A )*X = alpha*B.
-!
-! SIDE = 'R' or 'r' X*op( A ) = alpha*B.
-!
-! Unchanged on exit.
-!
-! UPLO - CHARACTER*1.
-! On entry, UPLO specifies whether the matrix A is an upper or
-! lower triangular matrix as follows:
-!
-! UPLO = 'U' or 'u' A is an upper triangular matrix.
-!
-! UPLO = 'L' or 'l' A is a lower triangular matrix.
-!
-! Unchanged on exit.
-!
-! TRANSA - CHARACTER*1.
-! On entry, TRANSA specifies the form of op( A ) to be used in
-! the matrix multiplication as follows:
-!
-! TRANSA = 'N' or 'n' op( A ) = A.
-!
-! TRANSA = 'T' or 't' op( A ) = A'.
-!
-! TRANSA = 'C' or 'c' op( A ) = A'.
-!
-! Unchanged on exit.
-!
-! DIAG - CHARACTER*1.
-! On entry, DIAG specifies whether or not A is unit triangular
-! as follows:
-!
-! DIAG = 'U' or 'u' A is assumed to be unit triangular.
-!
-! DIAG = 'N' or 'n' A is not assumed to be unit
-! triangular.
-!
-! Unchanged on exit.
-!
-! M - INTEGER.
-! On entry, M specifies the number of rows of B. M must be at
-! least zero.
-! Unchanged on exit.
-!
-! N - INTEGER.
-! On entry, N specifies the number of columns of B. N must be
-! at least zero.
-! Unchanged on exit.
-!
-! ALPHA - DOUBLE PRECISION.
-! On entry, ALPHA specifies the scalar alpha. When alpha is
-! zero then A is not referenced and B need not be set before
-! entry.
-! Unchanged on exit.
-!
-! A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
-! when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
-! Before entry with UPLO = 'U' or 'u', the leading k by k
-! upper triangular part of the array A must contain the upper
-! triangular matrix and the strictly lower triangular part of
-! A is not referenced.
-! Before entry with UPLO = 'L' or 'l', the leading k by k
-! lower triangular part of the array A must contain the lower
-! triangular matrix and the strictly upper triangular part of
-! A is not referenced.
-! Note that when DIAG = 'U' or 'u', the diagonal elements of
-! A are not referenced either, but are assumed to be unity.
-! Unchanged on exit.
-!
-! LDA - INTEGER.
-! On entry, LDA specifies the first dimension of A as declared
-! in the calling (sub) program. When SIDE = 'L' or 'l' then
-! LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
-! then LDA must be at least max( 1, n ).
-! Unchanged on exit.
-!
-! B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
-! Before entry, the leading m by n part of the array B must
-! contain the right-hand side matrix B, and on exit is
-! overwritten by the solution matrix X.
-!
-! LDB - INTEGER.
-! On entry, LDB specifies the first dimension of B as declared
-! in the calling (sub) program. LDB must be at least
-! max( 1, m ).
-! Unchanged on exit.
-!
-!
-! Level 3 Blas routine.
-!
-!
-! -- Written on 8-February-1989.
-! Jack Dongarra, Argonne National Laboratory.
-! Iain Duff, AERE Harwell.
-! Jeremy Du Croz, Numerical Algorithms Group Ltd.
-! Sven Hammarling, Numerical Algorithms Group Ltd.
-!
-!
-! .. External Functions ..
-! .. External Subroutines ..
-! .. Intrinsic Functions ..
-! .. Local Scalars ..
-! .. Parameters ..
-! ..
-! .. Executable Statements ..
-!
-! Test the input parameters.
-!
- lside = LSAME(Side,'L')
- IF ( lside ) THEN
- nrowa = M
- ELSE
- nrowa = N
- ENDIF
- nounit = LSAME(Diag,'N')
- upper = LSAME(Uplo,'U')
-!
- info = 0
- IF ( (.NOT.lside) .AND. (.NOT.LSAME(Side,'R')) ) THEN
- info = 1
- ELSEIF ( (.NOT.upper) .AND. (.NOT.LSAME(Uplo,'L')) ) THEN
- info = 2
- ELSEIF ( (.NOT.LSAME(Transa,'N')) .AND. (.NOT.LSAME(Transa,'T')) &
- & .AND. (.NOT.LSAME(Transa,'C')) ) THEN
- info = 3
- ELSEIF ( (.NOT.LSAME(Diag,'U')) .AND. (.NOT.LSAME(Diag,'N')) ) &
- & THEN
- info = 4
- ELSEIF ( M<0 ) THEN
- info = 5
- ELSEIF ( N<0 ) THEN
- info = 6
- ELSEIF ( Lda<MAX(1,nrowa) ) THEN
- info = 9
- ELSEIF ( Ldb<MAX(1,M) ) THEN
- info = 11
- ENDIF
- IF ( info/=0 ) THEN
- CALL XERBLA('DTRSM ',info)
- RETURN
- ENDIF
-!
-! Quick return if possible.
-!
- IF ( N==0 ) RETURN
-!
-! And when alpha.eq.zero.
-!
- IF ( Alpha==ZERO ) THEN
- DO j = 1 , N
- DO i = 1 , M
- B(i,j) = ZERO
- ENDDO
- ENDDO
- RETURN
- ENDIF
-!
-! Start the operations.
-!
- IF ( lside ) THEN
- IF ( LSAME(Transa,'N') ) THEN
-!
-! Form B := alpha*inv( A )*B.
-!
- IF ( upper ) THEN
- DO j = 1 , N
- IF ( Alpha/=ONE ) THEN
- DO i = 1 , M
- B(i,j) = Alpha*B(i,j)
- ENDDO
- ENDIF
- DO k = M , 1 , -1
- IF ( B(k,j)/=ZERO ) THEN
- IF ( nounit ) B(k,j) = B(k,j)/A(k,k)
- DO i = 1 , k - 1
- B(i,j) = B(i,j) - B(k,j)*A(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ELSE
- DO j = 1 , N
- IF ( Alpha/=ONE ) THEN
- DO i = 1 , M
- B(i,j) = Alpha*B(i,j)
- ENDDO
- ENDIF
- DO k = 1 , M
- IF ( B(k,j)/=ZERO ) THEN
- IF ( nounit ) B(k,j) = B(k,j)/A(k,k)
- DO i = k + 1 , M
- B(i,j) = B(i,j) - B(k,j)*A(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDDO
- ENDIF
-!
-! Form B := alpha*inv( A' )*B.
-!
- ELSEIF ( upper ) THEN
- DO j = 1 , N
- DO i = 1 , M
- temp = Alpha*B(i,j)
- DO k = 1 , i - 1
- temp = temp - A(k,i)*B(k,j)
- ENDDO
- IF ( nounit ) temp = temp/A(i,i)
- B(i,j) = temp
- ENDDO
- ENDDO
- ELSE
- DO j = 1 , N
- DO i = M , 1 , -1
- temp = Alpha*B(i,j)
- DO k = i + 1 , M
- temp = temp - A(k,i)*B(k,j)
- ENDDO
- IF ( nounit ) temp = temp/A(i,i)
- B(i,j) = temp
- ENDDO
- ENDDO
- ENDIF
- ELSEIF ( LSAME(Transa,'N') ) THEN
-!
-! Form B := alpha*B*inv( A ).
-!
- IF ( upper ) THEN
- DO j = 1 , N
- IF ( Alpha/=ONE ) THEN
- DO i = 1 , M
- B(i,j) = Alpha*B(i,j)
- ENDDO
- ENDIF
- DO k = 1 , j - 1
- IF ( A(k,j)/=ZERO ) THEN
- DO i = 1 , M
- B(i,j) = B(i,j) - A(k,j)*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- IF ( nounit ) THEN
- temp = ONE/A(j,j)
- DO i = 1 , M
- B(i,j) = temp*B(i,j)
- ENDDO
- ENDIF
- ENDDO
- ELSE
- DO j = N , 1 , -1
- IF ( Alpha/=ONE ) THEN
- DO i = 1 , M
- B(i,j) = Alpha*B(i,j)
- ENDDO
- ENDIF
- DO k = j + 1 , N
- IF ( A(k,j)/=ZERO ) THEN
- DO i = 1 , M
- B(i,j) = B(i,j) - A(k,j)*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- IF ( nounit ) THEN
- temp = ONE/A(j,j)
- DO i = 1 , M
- B(i,j) = temp*B(i,j)
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-!
-! Form B := alpha*B*inv( A' ).
-!
- ELSEIF ( upper ) THEN
- DO k = N , 1 , -1
- IF ( nounit ) THEN
- temp = ONE/A(k,k)
- DO i = 1 , M
- B(i,k) = temp*B(i,k)
- ENDDO
- ENDIF
- DO j = 1 , k - 1
- IF ( A(j,k)/=ZERO ) THEN
- temp = A(j,k)
- DO i = 1 , M
- B(i,j) = B(i,j) - temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- IF ( Alpha/=ONE ) THEN
- DO i = 1 , M
- B(i,k) = Alpha*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- ELSE
- DO k = 1 , N
- IF ( nounit ) THEN
- temp = ONE/A(k,k)
- DO i = 1 , M
- B(i,k) = temp*B(i,k)
- ENDDO
- ENDIF
- DO j = k + 1 , N
- IF ( A(j,k)/=ZERO ) THEN
- temp = A(j,k)
- DO i = 1 , M
- B(i,j) = B(i,j) - temp*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- IF ( Alpha/=ONE ) THEN
- DO i = 1 , M
- B(i,k) = Alpha*B(i,k)
- ENDDO
- ENDIF
- ENDDO
- ENDIF
-!
-!
-! End of DTRSM .
-!
- END SUBROUTINE DTRSM
-!*==IDAMAX.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- FUNCTION IDAMAX(N,Dx,Incx)
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - N
-!A INPUT - DX
-!A INPUT - INCX
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls ** NOTHING **
-! called by DGETF2
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars DMAX I IX
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- INTEGER :: Incx , N
- DOUBLE PRECISION , DIMENSION(*) :: Dx
- INTEGER :: IDAMAX
- INTENT (IN) Dx , Incx , N
-!
-! Local variables
-!
- DOUBLE PRECISION , INTRINSIC :: DABS
- DOUBLE PRECISION :: dmax
- INTEGER :: i , ix
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! finds the index of element having max. absolute value.
-! jack dongarra, linpack, 3/11/78.
-! modified 3/93 to return if incx .le. 0.
-! modified 12/3/93, array(1) declarations changed to array(*)
-!
-!
- IDAMAX = 0
- IF ( N<1 .OR. Incx<=0 ) RETURN
- IDAMAX = 1
- IF ( N==1 ) RETURN
- IF ( Incx==1 ) THEN
-!
-! code for increment equal to 1
-!
- dmax = DABS(Dx(1))
- DO i = 2 , N
- IF ( DABS(Dx(i))>dmax ) THEN
- IDAMAX = i
- dmax = DABS(Dx(i))
- ENDIF
- ENDDO
- GOTO 99999
- ENDIF
-!
-! code for increment not equal to 1
-!
- ix = 1
- dmax = DABS(Dx(1))
- ix = ix + Incx
- DO i = 2 , N
- IF ( DABS(Dx(ix))>dmax ) THEN
- IDAMAX = i
- dmax = DABS(Dx(ix))
- ENDIF
- ix = ix + Incx
- ENDDO
- RETURN
-99999 END FUNCTION IDAMAX
-!*==XERBLA.spg processed by SPAG 6.55Dc at 12:01 on 5 Feb 2004
- SUBROUTINE XERBLA(Srname,Info)
- IMPLICIT NONE
-!*--********************************************************************
-!A INPUT - SRNAME
-!A INPUT - INFO
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-! calls ** NOTHING **
-! called by DGEMM DGEMV DGER DGETF2 DGETRF DGETRI
-! DTRMM DTRMV DTRSM DTRTI2 DTRTRI
-! modifies ** NOTHING **
-! uses value ** NOTHING **
-! local vars *** NONE ****
-! uses PARAMs *** NONE ****
-!*++********************************************************************
-!
-!*** Start of declarations rewritten by SPAG
-!
-! Dummy arguments
-!
- INTEGER :: Info
- CHARACTER(6) :: Srname
- INTENT (IN) Info , Srname
-!
-!*** End of declarations rewritten by SPAG
-!
-!
-! -- LAPACK auxiliary routine (preliminary version) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! Courant Institute, Argonne National Lab, and Rice University
-! February 29, 1992
-!
-! .. Scalar Arguments ..
-! ..
-!
-! Purpose
-! =======
-!
-! XERBLA is an error handler for the LAPACK routines.
-! It is called by an LAPACK routine if an input parameter has an
-! invalid value. A message is printed and execution stops.
-!
-! Installers may consider modifying the STOP statement in order to
-! call system-specific exception-handling facilities.
-!
-! Arguments
-! =========
-!
-! SRNAME (input) CHARACTER*6
-! The name of the routine which called XERBLA.
-!
-! INFO (input) INTEGER
-! The position of the invalid parameter in the parameter list
-! of the calling routine.
-!
-!
- WRITE (*,FMT=99001) Srname , Info
-!
- STOP
-!
-99001 FORMAT (' ** On entry to ',A6,' parameter number ',I2,' had ', &
- & 'an illegal value')
-!
-! End of XERBLA
-!
- END SUBROUTINE XERBLA
Removed: dragonegg/trunk/test/compilator/local/wrf_module_ra_gfdleta_MINIMIZED.f90
URL: http://llvm.org/viewvc/llvm-project/dragonegg/trunk/test/compilator/local/wrf_module_ra_gfdleta_MINIMIZED.f90?rev=176082&view=auto
==============================================================================
--- dragonegg/trunk/test/compilator/local/wrf_module_ra_gfdleta_MINIMIZED.f90 (original)
+++ dragonegg/trunk/test/compilator/local/wrf_module_ra_gfdleta_MINIMIZED.f90 (removed)
@@ -1,1062 +0,0 @@
-MODULE module_ra_gfdleta
- INTEGER, PARAMETER :: NBLY=15
- REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), &
- SOURCE(28,NBLY), DSRCE(28,NBLY)
- REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,&
- C2D58,CO258
- REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, &
- C2DM51,C2DM58
-CONTAINS
- SUBROUTINE GFDLETAINIT(SFULL,SHALF,PPTOP,JULYR,MONTH,IDAY,GMT, &
- & kds,kde,kms,kme,kts,kte)
- END SUBROUTINE GFDLETAINIT
- SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,PI3D &
- & ,XLAND,p8w,dz8w,RHO_PHY,P_PHY,T &
- & ,QV,QL,TSK2D,GLW,GSW &
- & ,TOTSWDN,TOTLWDN,RSWTOA,RLWTOA,CZMEAN & !Added
- & ,GLAT,GLON,HTOP,HBOT,ALBEDO,CUPPT &
- & ,VEGFRA,SNOW,G,GMT & !Modified
- & ,NSTEPRA,NPHS,itimestep & !Modified
- & ,julyr,julday,gfdl_lw,gfdl_sw &
- & ,CFRACL,CFRACM,CFRACH & !Added
- & ,ACFRST,NCFRST,ACFRCV,NCFRCV & !Added
- & ,IDS,IDE,JDS,JDE,KDS,KDE &
- & ,IMS,IME,JMS,JME,KMS,KME &
- & ,ITS,ITE,JTS,JTE,KTS,KTE)
- INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE &
- & ,NPHS,NSTEPRA
- INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added
- ,NCFRCV !Added
- REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: &
- THRATEN,THRATENLW,THRATENSW
- REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, &
- & PI3D
- REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, &
- & TSK2D,VEGFRA, &
- & XLAND
- REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON
- REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,CUPPT
- REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added
- & RLWTOA, & !Added
- & ACFRST, & !Added
- & ACFRCV
- REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW
- REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN, &
- & TOTLWDN,TOTSWDN
- REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CFRACL,CFRACM, & !Added
- & CFRACH !Added
- LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
- REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QFLIP,QLFLIP, &
- & TFLIP
- REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP,PHYD
- REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
- INTEGER :: IDAT(3),Jmonth,Jday
- DO J=JTS,JTE
- DO I=ITS,ITE
- ENDDO
- ENDDO
- DO K = KMS,KME
- DO J = jts,jte
- DO I = its,ite
- ENDDO
- ENDDO
- ENDDO
- CALL RADTN (DT,TFLIP,QFLIP,QLFLIP,PFLIP,P8WFLIP,XLAND,TSK2D, &
- & GLAT,GLON,HTOP,HBOT,ALBEDO,CUPPT, &
- & ACFRCV,NCFRCV,ACFRST,NCFRST, &
- & VEGFRA,SNOW,GLW,GSW, &
- & TOTSWDN,TOTLWDN, & !Added
- & IDAT,IHRST, &
- & NSTEPRA,NSTEPRA,NPHS,itimestep, & !Modified
- & TENDS,TENDL,RSWTOA,RLWTOA,CZMEAN, &
- & CFRACL,CFRACM,CFRACH, & !Added
- & ids,ide, jds,jde, kds,kde, &
- & ims,ime, jms,jme, kms,kme, &
- & its,ite, jts,jte, kts,kte )
- IF ( gfdl_lw ) then
- DO J=JTS,JTE
- DO K = KTS,KTE
- DO I=ITS,ITE
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- IF ( gfdl_sw ) then
- DO J=JTS,JTE
- DO K = KTS,KTE
- ENDDO
- ENDDO
- ENDIF
- DO J=JTS,JTE
- DO I=ITS,ITE
- ENDDO
- ENDDO
- 100 IF ( gfdl_sw ) then
- DO J=JTS,JTE
- DO K = KTS,KTE
- DO I=ITS,ITE
- ENDDO
- ENDDO
- ENDDO
- ENDIF
- END SUBROUTINE ETARA
- SUBROUTINE RADTN(DT,T,Q,CWM,PFLIP,P8WFLIP,XLAND,TSK2D, &
- & GLAT,GLON,HTOP,HBOT,ALB,CUPPT, &
- & ACFRCV,NCFRCV,ACFRST,NCFRST, &
- & VEGFRC,SNO,GLW,GSW, &
- & RSWIN,RLWIN, & !Added
- & IDAT,IHRST, &
- & NRADS,NRADL,NPHS,NTSD, &
- & TENDS,TENDL,RSWTOA,RLWTOA,CZMEAN, &
- & CFRACL,CFRACM,CFRACH, & !Added
- & ids,ide, jds,jde, kds,kde, &
- & ims,ime, jms,jme, kms,kme, &
- & its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- & its,ite, jts,jte, kts,kte
- INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
- REAL, PARAMETER :: CAPA=287.04/1004.6,DTR=3.1415926/180., &
- & WA=.10,WG=1.-WA,KSMUD=0
- REAL, PARAMETER :: SLPM=1.01325E5,EPSQ1=1.E-5,EPSQ=1.E-12, &
- & PI2=2.*3.14159265,RLAG=14.8125
- INTEGER, PARAMETER :: NB=12
- LOGICAL :: SHORT,LONG
- LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITS,BITCP1,BITSP1
- LOGICAL :: CNCLD
- REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D
- REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,CWM,T
- REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP, &
- & P8WFLIP
- REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN &
- & ,RSWIN,RLWIN & !Added
- & ,CFRACL,CFRACM &
- & ,CFRACH
- REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: HTOP,HBOT
- REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO
- REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON
- REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: CUPPT
- REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST &
- ,RSWTOA,RLWTOA
- INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST
- REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC
- REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
- & TENDS
- REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, &
- & SLMSK,CV,SV,FLWUP, &
- & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, &
- & FLWUPS
- REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID
- REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN
- REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT
- INTEGER,DIMENSION(its:ite,kts:kte+1) :: ITYP,KBTM,KTOP
- INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD
- REAL, DIMENSION(its:ite) :: CSTR,TAUC,TAUDAR
- REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL
- REAL :: CWMKL,TMT15,AI,BI,PP,QW,P1,CC2,CC1,PMOD,CLPFIL, &
- & DTHDP,DDP
- INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, &
- & JD,II
- IF(SHORT)THEN
- DO J=MYJS,MYJE
- DO I=MYIS,MYIE
- ENDDO
- ENDDO
- DO II=0,NRADS,NPHS
- ENDDO
- ENDIF
- DO I=MYIS,MYIE
- ENDDO
- DO L=1,LML
- ENDDO
- IF(LVLIJ.GT.0)THEN
- DO L=LVLIJ,1,-1
- ENDDO
- ENDIF
- IF(LVLIJ.EQ.0) THEN
- ENDIF
- IF ((XLAND(I,J)-1.5) .gt. 0.) then
- ENDIF
- IF(RQKL.GE.0.9999)THEN
- ENDIF
- IF((XLAND(I,J)-1.) .LT. 0.5)THEN
- DO L=1,LML
- ENDDO
- ENDIF
- IF((XLAND(I,J)-1.) .GT. 0.5)THEN
- DO L=1,LML-1
- IF(DTHDP.LE.CLAPSE)THEN
- ENDIF
- ENDDO
- IF(CSMID(I,LBASE-1).LE.0..AND.CSMID(I,LBASE-2).LE.0. &
- .AND.LBASE.LT.LM)THEN
- IF(DTHDP.GT.CLPSE)THEN
- ENDIF
- DO L=1,LML
- ENDDO
- DO L=1,LML
- ENDDO
- ENDIF
- ENDIF
- DO L=1,LML
- ENDDO
- DO LL=L400,2,-1
- IF(DTHDP.LT.-0.0025.OR.QMID(I,LL).LE.EPSQ1)THEN
- ENDIF
- ENDDO
- 340 IF(LTROP.LT.LM)THEN
- DO LL=LTROP,1,-1
- ENDDO
- ENDIF
- IF(BIT1)THEN
- IF(ITYP(I,KCLD(I)).EQ.0)THEN
- IF(BITC)THEN
- ENDIF
- IF(BITC)THEN
- IF(BITCP1)THEN
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- IF(NCLD.GE.1)THEN
- IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN
- IF(ITYP(I,NC).EQ.2 &
- .OR.PINT(I,KTOP(I,NC)).LE.PTOPC(3))THEN
- IF(TCLD.LE.-10.0)THEN
- ENDIF
- IF(TCLD.LE.-20.0)THEN
- TAUC(I)=TAUC(I)+DELP*AMAX1(0.1E-3,2.56E-5* &
- (TCLD+82.5)**2)
- ENDIF
- ENDIF
- ENDIF
- IF(QSUM.GE.EPSQ1)THEN
- IF(BITX)THEN
- IF(ABS(EEX).GE.1.E-8)THEN
- ENDIF
- ENDIF
- ENDIF
- ENDIF
- DO L=1,LM
- DO I=MYIS,MYIE
- ENDDO
- ENDDO
- CALL OZON2D(LM,POZN,XLAT,RSIN1,RCOS1,RCOS2,OZN, &
- MYIS,MYIE, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
- CALL RADFS &
- (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT &
- , CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL &
- , COSZ,TAUDAR,1 &
- , 1,0 &
- , ITIMSW,ITIMLW,JD,HOUR &
- , TENDS(its,kts,j),TENDL(its,kts,j) &
- , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS &
- , ids,ide, jds,jde, kds,kde &
- , ims,ime, jms,jme, kms,kme &
- , its,ite, jts,jte, kts,kte )
- IF(LONG)THEN
- DO I=MYIS,MYIE
- ENDDO
- ENDIF
- IF(SHORT)THEN
- IF(CNCLD)THEN
- IF(PMOD.LE.PPT(1))THEN
- ENDIF
- ENDIF
- ENDIF
- DO L=1,LM
- ENDDO
- IF(LONG)THEN
- ENDIF
- IF(SHORT) THEN
- ENDIF
- IF(LONG)THEN
- ENDIF
- END SUBROUTINE RADTN
- SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, &
- its,ite, jts,jte, kts,kte)
- REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, &
- ZEROJD=2451545.0
- REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, &
- ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG
- LOGICAL :: LEAP
- IF(MOD(IDAT(3),4).EQ.0)THEN
- ENDIF
- IF(DAYI.GT.365.)THEN
- IF(.NOT.LEAP)THEN
- ENDIF
- ENDIF
- END SUBROUTINE ZENITH
- SUBROUTINE OZON2D (LK,POZN,XLAT,RSIN1,RCOS1,RCOS2,QO3, &
- MYIS,MYIE, &
- ids,ide, jds,jde, kds,kde, &
- ims,ime, jms,jme, kms,kme, &
- its,ite, jts,jte, kts,kte )
- REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN
- REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT
- REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3
- DO I=MYIS,MYIE
- ENDDO
- DO I=MYIS,MYIE
- IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN
- ENDIF
- ENDDO
- IF(POZN(I,K).LT.PRGFDL(1))THEN
- QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ &
- (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I)))
- ENDIF
- END SUBROUTINE OZON2D
- SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, &
- its,ite, jts,jte, kts,kte )
- REAL :: O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), &
- O3LO4(10,16)
- REAL :: O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33)
- REAL :: RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), &
- PHALF(kts:kte+1),P(81),PH(82)
- EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46))
- DATA PH1/ 0., &
- 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
- 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
- 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
- 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
- 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
- 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
- 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
- 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
- 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
- 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
- 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
- DATA PH2/ &
- 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
- 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
- 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
- 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
- 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
- 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
- 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
- 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
- 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
- 0.1000000E+01/
- DATA P1/ &
- 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
- 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
- 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
- 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
- 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
- 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
- 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
- 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
- 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
- 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
- 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
- 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
- DATA O3HI1/ &
- .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
- .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
- .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
- .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
- .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
- .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
- .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
- .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
- 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, &
- 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
- 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
- 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
- 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
- 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
- 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
- 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
- DATA O3LO1/ &
- 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
- 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
- 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
- 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
- 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
- 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
- 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
- .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
- .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
- .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
- .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
- .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
- .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
- .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
- .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
- .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
- DATA O3LO2/ &
- 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
- 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
- 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
- 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
- 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
- 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
- .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
- .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
- .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
- .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
- .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
- .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
- .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
- .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
- .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
- .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
- DATA O3LO3/ &
- 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
- 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
- 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
- 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
- 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
- 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
- .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
- .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
- .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
- .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
- .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
- .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
- .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
- .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
- .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
- .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
- DATA O3LO4/ &
- 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, &
- 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, &
- 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, &
- 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, &
- 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, &
- 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, &
- 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, &
- .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, &
- .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, &
- .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, &
- .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, &
- .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, &
- .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, &
- .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, &
- .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, &
- .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/
- IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K)
- IF (IPLACE.EQ.1) THEN
- END IF
- END SUBROUTINE O3INT
- SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP &
- , ids,ide, jds,jde, kds,kde &
- , its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- its,ite, jts,jte, kts,kte
- IF (NCLDS(IR).EQ.0) THEN
- IF(K2+1.LE.K1-1) THEN
- ENDIF
- ENDIF
- END SUBROUTINE CLO89
- SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, &
- APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, &
- ids,ide, jds,jde, kds,kde, &
- its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- its,ite, jts,jte, kts,kte
- REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
- BCOMB,BETACM
- REAL, DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,&
- CO2R2,D2CD22,DCO2D2,CO2SP1,&
- TLSQU,DIFT
- REAL, DIMENSION(its:ite,kts:kte) :: DELP2,DELP,CO2NBL,&
- QH2O,VV,VAR1,VAR2,VAR3,VAR4
- REAL, DIMENSION(its:ite,kts:kte*2+1):: EMPL
- REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21
- EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) &
- *GP0INV
- CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* &
- D2CD22(I,K))
- DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ &
- (TSTDAV(I,KP)-TSTDAV(I,K))
- CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ &
- HAF*DIFT(I,KP)*D2CDT2(I,KP))
- END SUBROUTINE LWR88
- SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, &
- QH2O,PRESS,P,DELP,DELP2,TEMP,T, &
- CO21,CO2NBL,CO2SP1,CO2SP2, &
- VAR1,VAR2,VAR3,VAR4,CNTVAL, &
- ids,ide, jds,jde, kds,kde, &
- its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- its,ite, jts,jte, kts,kte
- REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: CO2NBL,DELP2, &
- VAR1,VAR2,VAR3,VAR4
- REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, &
- CTSO3,CTS
- END SUBROUTINE FST88
- SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, &
- its,ite, jts,jte, kts,kte )
- REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS
- G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ &
- DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29)
- G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ &
- DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29)
- G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ &
- DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29)
- END SUBROUTINE E1E290
- SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, &
- RADCON, &
- ids,ide, jds,jde, kds,kde, &
- its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- RADCON
- REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: CTSO3
- CTSO3(I,K)=RADCON*DELP(I,K)* &
- (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + &
- SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K)))
- END SUBROUTINE SPA88
- SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, &
- ids,ide, jds,jde, kds,kde, &
- its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- its,ite, jts,jte, kts,kte
- END SUBROUTINE E290
- SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, &
- its,ite, jts,jte, kts,kte )
- END SUBROUTINE E2SPEC
- SUBROUTINE E3V88(EMV,TV,AV, &
- ids,ide, jds,jde, kds,kde, &
- its,ite, jts,jte, kts,kte )
- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , &
- its,ite, jts,jte, kts,kte
- REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV
- REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,&
- FYO
- EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ &
- DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20)
- END SUBROUTINE E3V88
- SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL, &
- its,ite, jts,jte, kts,kte )
- END SUBROUTINE SWR93
- SUBROUTINE RADFS &
- (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
- , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL &
- , COSZRO,TAUDAR,IBEG &
- , KO3,KALB &
- , ITIMSW,ITIMLW &
- , JD,GMT &
- , SWH,HLW &
- , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS &
- , ids,ide, jds,jde, kds,kde &
- , ims,ime, jms,jme, kms,kme &
- , its,ite, jts,jte, kts,kte )
- INTEGER, PARAMETER :: NB=12
- REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT
- REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O
- REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD
- REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT
- REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR
- REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS
- INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS
- INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM
- REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL
- REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3
- REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, &
- BCOMB,BETACM
- DATA ACOMB / &
- -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, &
- 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, &
- 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, &
- 0.281662E-01, 0.199525E-01, 0.370962E-01/
- REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, &
- FSWDNS,FLWUP,FLWDNS
- REAL, DIMENSION(21,20) :: ALBD
- REAL, DIMENSION(21) :: TRN
- DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, &
- .70,.75,.80,.85,.90,.95,1.00/
- REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6)
- EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), &
- (ALB33(1,1),ALBD(1,15))
- DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, &
- .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, &
- .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, &
- .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, &
- .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, &
- .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, &
- .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, &
- .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, &
- .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, &
- .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, &
- .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, &
- .246,.235,.222,.211,.205,.200/
- DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, &
- .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, &
- .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, &
- .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, &
- .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, &
- .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, &
- .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, &
- .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, &
- .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, &
- .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, &
- .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, &
- .058,.055,.054,.053,.052,.052/
- DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, &
- .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, &
- .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, &
- .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, &
- .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, &
- .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, &
- .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, &
- .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, &
- .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, &
- .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/
- 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', &
- 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2)
- END SUBROUTINE RADFS
- SUBROUTINE O3CLIM
- INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1
- REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) &
- ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16)
- REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) &
- ,PHALF(NL),P(81),PH(82)
- DATA PH1/ 0., &
- 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, &
- 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, &
- 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, &
- 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, &
- 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, &
- 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, &
- 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, &
- 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, &
- 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, &
- 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, &
- 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/
- DATA PH2/ &
- 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, &
- 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, &
- 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, &
- 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, &
- 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, &
- 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, &
- 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, &
- 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, &
- 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, &
- 0.1000000E+01/
- DATA P1/ &
- 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, &
- 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, &
- 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, &
- 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, &
- 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, &
- 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, &
- 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, &
- 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, &
- 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, &
- 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, &
- 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, &
- 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/
- DATA P2/ &
- 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, &
- 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, &
- 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, &
- 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, &
- 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, &
- 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, &
- 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, &
- 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, &
- 0.1000000E+01/
- DATA O3HI1/ &
- .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, &
- .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, &
- .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, &
- .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, &
- .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, &
- .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, &
- .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, &
- .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, &
- 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, &
- 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, &
- 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, &
- 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, &
- 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, &
- 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, &
- 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, &
- 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/
- DATA O3LO1/ &
- 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, &
- 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, &
- 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, &
- 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, &
- 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, &
- 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, &
- 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, &
- .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, &
- .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, &
- .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, &
- .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, &
- .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, &
- .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, &
- .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, &
- .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, &
- .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/
- DATA O3LO2/ &
- 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, &
- 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, &
- 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, &
- 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, &
- 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, &
- 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, &
- .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, &
- .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, &
- .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, &
- .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, &
- .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, &
- .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, &
- .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, &
- .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, &
- .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, &
- .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/
- DATA O3LO3/ &
- 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, &
- 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, &
- 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, &
- 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, &
- 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, &
- 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, &
- .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, &
- .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, &
- .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, &
- .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, &
- .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, &
- .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, &
- .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, &
- .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, &
- .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, &
- .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/
- DO I=1,NLGTH
- ENDDO
- DO N=1,NL
- ENDDO
- END SUBROUTINE O3CLIM
- SUBROUTINE TABLE
- INTEGER :: IBAND(40)
- REAL :: BANDL1(64),BANDL2(64),BANDL3(35)
- REAL :: BANDH1(64),BANDH2(64),BANDH3(35)
- REAL :: &
- R1T(28),R2(28),S2(28),T3(28),R1WD(28)
- REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35)
- REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35)
- REAL :: BETAD1(64),BETAD2(64),BETAD3(35)
- DATA IBAND / &
- 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, &
- 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, &
- 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, &
- 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/
- DATA BANDL1 / &
- 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, &
- 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, &
- 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, &
- 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, &
- 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, &
- 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, &
- 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, &
- 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, &
- 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, &
- 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, &
- 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, &
- 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, &
- 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, &
- 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, &
- 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, &
- 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/
- DATA BANDL2 / &
- 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, &
- 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, &
- 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, &
- 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, &
- 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, &
- 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, &
- 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, &
- 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, &
- 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, &
- 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, &
- 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, &
- 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, &
- 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, &
- 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, &
- 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, &
- 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/
- DATA BANDL3 / &
- 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, &
- 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, &
- 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, &
- 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, &
- 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, &
- 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, &
- 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, &
- 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, &
- 0.218000E+04, 0.219000E+04, 0.227000E+04/
- DATA BANDH1 / &
- 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, &
- 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, &
- 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, &
- 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, &
- 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, &
- 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, &
- 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, &
- 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, &
- 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, &
- 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, &
- 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, &
- 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, &
- 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, &
- 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, &
- 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, &
- 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/
- DATA BANDH2 / &
- 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, &
- 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, &
- 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, &
- 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, &
- 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, &
- 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, &
- 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, &
- 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, &
- 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, &
- 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, &
- 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, &
- 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, &
- 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, &
- 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, &
- 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, &
- 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/
- DATA BANDH3 / &
- 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, &
- 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, &
- 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, &
- 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, &
- 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, &
- 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, &
- 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, &
- 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, &
- 0.219000E+04, 0.220000E+04, 0.238000E+04/
- DATA ARNDM1 / &
- 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, &
- 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, &
- 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, &
- 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, &
- 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, &
- 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, &
- 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, &
- 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, &
- 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, &
- 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, &
- 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, &
- 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, &
- 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, &
- 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, &
- 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, &
- 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/
- DATA ARNDM2 / &
- 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, &
- 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, &
- 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, &
- 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, &
- 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, &
- 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, &
- 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, &
- 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, &
- 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, &
- 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, &
- 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, &
- 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, &
- 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, &
- 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, &
- 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, &
- 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/
- DATA ARNDM3 / &
- 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, &
- 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, &
- 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, &
- 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, &
- 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, &
- 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, &
- 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, &
- 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, &
- 0.919409E-01, 0.155521E-01, 0.537083E-02/
- DATA BRNDM1 / &
- 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, &
- 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, &
- 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, &
- 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, &
- 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, &
- 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, &
- 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, &
- 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, &
- 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, &
- 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, &
- 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, &
- 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, &
- 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, &
- 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, &
- 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, &
- 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/
- DATA BRNDM2 / &
- 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, &
- 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, &
- 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, &
- 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, &
- 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, &
- 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, &
- 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, &
- 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, &
- 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, &
- 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, &
- 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, &
- 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, &
- 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, &
- 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, &
- 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, &
- 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/
- DATA BETAD1 / &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, &
- 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, &
- 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, &
- 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, &
- 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, &
- 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/
- DATA BETAD2 / &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/
- DATA BETAD3 / &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, &
- 0.000000E+00, 0.000000E+00, 0.000000E+00/
- IF (IA.EQ.2) THEN
- ENDIF
- IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
- ENDIF
- IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN
- ENDIF
- END SUBROUTINE TABLE
- SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR)
- JD=IDAY-32075 &
- -3*((JULYR+4900+(MONTH-14)/12)/100)/4
- IF(JHR.GE.12)THEN
- END IF
- END SUBROUTINE SOLARD
- SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday)
- LOGICAL :: LEAP,NOT_FIND_DATE
- DO WHILE (NOT_FIND_DATE)
- IF(itmpday.GT.MONTH(i))THEN
- ENDIF
- END DO
- END SUBROUTINE CAL_MON_DAY
- FUNCTION ANTEMP(L,Z)
- REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7)
- DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, &
- 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/
- DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, &
- 1.0, 1.5, 1.0, 1.0, 1.0/
- DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, &
- 30.0, 35.0, 50.0, 70.0, 100.0/
- DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, &
- 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/
- DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, &
- 71.0, 84.8520, 90.0, 91.0, 92.0/
- DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, &
- -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/
- END FUNCTION ANTEMP
- SUBROUTINE COEINT(RAT,IR)
- END SUBROUTINE COEINT
- SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1)
- DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
- CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
- IF (IQ.EQ.1.OR.IQ.EQ.4) THEN
- ENDIF
- END SUBROUTINE CO2INS
- SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2)
- END SUBROUTINE CO2INT
- SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1)
- DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), &
- CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1)
- IF (IQ.EQ.1) THEN
- ENDIF
- IF (IQ.GE.1.AND.IQ.LE.4) THEN
- ENDIF
- END SUBROUTINE CO2IN1
- SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
- SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2)
- END SUBROUTINE CO2PTZ
- FUNCTION PATH(A,B,C,E)
- END FUNCTION PATH
- SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F)
- END SUBROUTINE QINTRP
- SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS)
- END SUBROUTINE QUADSR
- SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, &
- SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2)
- DIMENSION T41(KP2,2),T42(KP), &
- T43(KP2,2),T44(KP)
- END SUBROUTINE SIGP
- SUBROUTINE SINTR2
- END SUBROUTINE SINTR2
- SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2)
- LOGICAL , EXTERNAL :: wrf_dm_on_monitor
- DIMENSION T41(LP2,2),T42(LP1), &
- T43(LP2,2),T44(LP1)
- DO K=1,L
- ENDDO
- DO K1=1,LP1
- DO K2=1,LP1
- ENDDO
- ENDDO
- IF ( wrf_dm_on_monitor() ) THEN
- ENDIF
- END SUBROUTINE CO2O3
- SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
- LOGICAL :: opened
- LOGICAL , EXTERNAL :: wrf_dm_on_monitor
- IF ( wrf_dm_on_monitor() ) THEN
- DO i = 14,99
- IF ( .NOT. opened ) THEN
- ENDIF
- ENDDO
- ENDIF
- DO KK=1,2
- ENDDO
- DO K=1,LP1
- ENDDO
- DO J=1,LP1
- DO I=1,LP1
- ENDDO
- ENDDO
- DO K=1,LP1
- ENDDO
- END SUBROUTINE CONRAD
- END MODULE module_RA_GFDLETA
More information about the llvm-commits
mailing list