Add files via upload
This commit is contained in:
Xuesong (Steve)
356
code/new/adBuffer.c
Normal file
356
code/new/adBuffer.c
Normal file
@ -0,0 +1,356 @@
|
||||
/*
|
||||
C implementation of C$Id: adBuffer.f 3723 2011-02-24 13:34:42Z llh $
|
||||
|
||||
Replac the faulty PUSH/POPs by assignments to/from local arrays,
|
||||
each of them being declared localized to its thread, make it
|
||||
thread-safe for OPENMP.
|
||||
|
||||
If the OPENMP THREAD NUMBER IS GREATER THAN 256 on a single node,
|
||||
the STACK_POOL_SEZE needs to be increased.
|
||||
|
||||
This portion just ported the necessary codes which used by WRFPLUS
|
||||
from adBuffer.f, NOT THE WHOLE CODES.
|
||||
Check it carefully before using for your own case.
|
||||
|
||||
2011-10-10 jliu@ucar.edu
|
||||
*/
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
|
||||
/*
|
||||
#ifdef _OPENMP
|
||||
*/
|
||||
#include <omp.h>
|
||||
#define STACK_POOL_SIZE 256
|
||||
/*
|
||||
#else
|
||||
#define omp_get_thread_num() 0
|
||||
#define STACK_POOL_SIZE 1
|
||||
#endif
|
||||
*/
|
||||
#define BUFF_SIZE 512
|
||||
|
||||
#define bit_set(x,y) ((x) | ((unsigned long)0x00000001 << (y)))
|
||||
#define bit_clear(x,y) ((x) & ~((unsigned long)0x00000001 << (y)))
|
||||
#define bit_test(x,y) ((x) >> (y) & (unsigned long)0x00000001)
|
||||
|
||||
typedef int logical;
|
||||
|
||||
static int c__1 = 1;
|
||||
static int c__512 = 512;
|
||||
static int c_n512 = -512;
|
||||
static int c__4 = 4;
|
||||
static int c_n2048 = -2048;
|
||||
static int c__8 = 8;
|
||||
static int c_n4096 = -4096;
|
||||
static int c__16 = 16;
|
||||
static int c_n8192 = -8192;
|
||||
static int c_b101 = 1000000;
|
||||
static int c__9 = 9;
|
||||
static int c__3 = 3;
|
||||
|
||||
static int adbitbuf[STACK_POOL_SIZE] = {0};
|
||||
static int adbitibuf[STACK_POOL_SIZE] = {0};
|
||||
|
||||
static int *adi4buf[STACK_POOL_SIZE] = {NULL};
|
||||
static int adi4ibuf[STACK_POOL_SIZE] = {0};
|
||||
|
||||
static double *adr8buf[STACK_POOL_SIZE] = {NULL};
|
||||
static int adr8ibuf[STACK_POOL_SIZE] = {0};
|
||||
|
||||
static int i4arrnum = 0;
|
||||
static int r8arrnum = 0;
|
||||
|
||||
static int i4num = 0;
|
||||
static int r8num = 0;
|
||||
|
||||
void print_ulong_bin(const unsigned long * const var, int bits) {
|
||||
int i;
|
||||
|
||||
#if defined(__LP64__) || defined(_LP64)
|
||||
if( (bits > 64) || (bits <= 0) )
|
||||
#else
|
||||
if( (bits > 32) || (bits <= 0) )
|
||||
#endif
|
||||
return;
|
||||
|
||||
for(i = 0; i < bits; i++) {
|
||||
printf("%lu", (*var >> (bits - 1 - i)) & 0x01);
|
||||
}
|
||||
printf("\n");
|
||||
}
|
||||
|
||||
/* ========================= BITS ============================*/
|
||||
int pushbit_( logical *bit )
|
||||
{
|
||||
int thread_id = omp_get_thread_num();
|
||||
|
||||
//printf("thread %i push %i bit %i\n", thread_id, *bit, adbitibuf[thread_id]);
|
||||
|
||||
if (*bit) {
|
||||
adbitbuf[thread_id] = bit_set(adbitbuf[thread_id],
|
||||
adbitibuf[thread_id]);
|
||||
} else {
|
||||
adbitbuf[thread_id] = bit_clear(adbitbuf[thread_id],
|
||||
adbitibuf[thread_id]);
|
||||
}
|
||||
if (adbitibuf[thread_id] == 31) {
|
||||
//printf("thread %02i : pushbit : pushinteger4 %03i : ",thread_id, i4num++);
|
||||
//print_ulong_bin(&adbitbuf[thread_id],32);
|
||||
pushinteger4_(&adbitbuf[thread_id]);
|
||||
adbitbuf[thread_id]=0;
|
||||
adbitibuf[thread_id]=0;
|
||||
} else {
|
||||
adbitibuf[thread_id]++;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
logical popbit_(void)
|
||||
{
|
||||
logical ret_val;
|
||||
int thread_id = omp_get_thread_num();
|
||||
if ( adbitibuf[thread_id] == 0 ) {
|
||||
//printf("thread %02i : popbit : popinteger4 %03i : ",thread_id, --i4num);
|
||||
//print_ulong_bin(&adbitbuf[thread_id],32);
|
||||
popinteger4_(&adbitbuf[thread_id]);
|
||||
adbitibuf[thread_id]=31;
|
||||
} else {
|
||||
adbitibuf[thread_id]--;
|
||||
}
|
||||
ret_val = bit_test(adbitbuf[thread_id], adbitibuf[thread_id]);
|
||||
//printf("thread %i pop %i bit %i\n", thread_id, ret_val, adbitibuf[thread_id]);
|
||||
return ret_val;
|
||||
}
|
||||
|
||||
/* ========================= CONTROL ========================= */
|
||||
|
||||
int pushcontrol1b_(int *cc)
|
||||
{
|
||||
logical L;
|
||||
L = *cc != 0;
|
||||
pushbit_(&L);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popcontrol1b_(int *cc)
|
||||
{
|
||||
if (popbit_()) {
|
||||
*cc = 1;
|
||||
} else {
|
||||
*cc = 0;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
int pushcontrol2b_(int *cc)
|
||||
{
|
||||
logical L;
|
||||
L = bit_test(*cc,0);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,1);
|
||||
pushbit_(&L);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popcontrol2b_(int *cc)
|
||||
{
|
||||
if (popbit_()) {
|
||||
*cc = 2;
|
||||
} else {
|
||||
*cc = 0;
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,0);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
int pushcontrol3b_(int *cc)
|
||||
{
|
||||
logical L;
|
||||
L = bit_test(*cc,0);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,1);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,2);
|
||||
pushbit_(&L);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popcontrol3b_(int *cc)
|
||||
{
|
||||
if (popbit_()) {
|
||||
*cc = 4;
|
||||
} else {
|
||||
*cc = 0;
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,1);
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,0);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
int pushcontrol4b_(int *cc)
|
||||
{
|
||||
logical L;
|
||||
L = bit_test(*cc,0);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,1);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,2);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,3);
|
||||
pushbit_(&L);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popcontrol4b_(int *cc)
|
||||
{
|
||||
if (popbit_()) {
|
||||
*cc = 8;
|
||||
} else {
|
||||
*cc = 0;
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,2);
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,1);
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,0);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
int pushcontrol5b_(int *cc)
|
||||
{
|
||||
logical L;
|
||||
L = bit_test(*cc,0);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,1);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,2);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,3);
|
||||
pushbit_(&L);
|
||||
L = bit_test(*cc,4);
|
||||
pushbit_(&L);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popcontrol5b_(int *cc)
|
||||
{
|
||||
if (popbit_()) {
|
||||
*cc = 16;
|
||||
} else {
|
||||
*cc = 0;
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,3);
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,2);
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,1);
|
||||
}
|
||||
if (popbit_()) {
|
||||
*cc = bit_set(*cc,0);
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* ======================= INTEGER*4 =========================: */
|
||||
|
||||
int pushinteger4_(int *x)
|
||||
{
|
||||
int thread_id = omp_get_thread_num();
|
||||
|
||||
if ( adi4buf[thread_id] == NULL ) {
|
||||
int *buf = (int*)calloc(BUFF_SIZE, sizeof(int));
|
||||
if ( buf == NULL ) {
|
||||
puts("Memory allocation failed.");
|
||||
exit(0);
|
||||
}
|
||||
adi4buf[thread_id] = buf;
|
||||
}
|
||||
adi4buf[thread_id][adi4ibuf[thread_id]] = *x;
|
||||
++adi4ibuf[thread_id];
|
||||
if ( adi4ibuf[thread_id] == BUFF_SIZE) {
|
||||
//printf("thread %02i : pushinteger4 : pushinteger4array : %04i : ", thread_id, ++i4arrnum);
|
||||
//printf("[0]: %i [%i] : %i\n",adi4buf[thread_id][0], adi4ibuf[thread_id]-1, adi4buf[thread_id][adi4ibuf[thread_id]-1]);
|
||||
pushinteger4array_(adi4buf[thread_id], &c__512);
|
||||
adi4ibuf[thread_id] = 0 ;
|
||||
}
|
||||
//printf("thread %i pushinteger4 %i buff %i\n ", thread_id, *x, adi4ibuf[thread_id]);
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popinteger4_(int *x)
|
||||
{
|
||||
int thread_id = omp_get_thread_num();
|
||||
|
||||
if ( adi4ibuf[thread_id] == 0 ) {
|
||||
popinteger4array_(adi4buf[thread_id], &c__512);
|
||||
adi4ibuf[thread_id] = BUFF_SIZE;
|
||||
//printf("thread %02i : popinteger4 : popinteger4array : %04i : ", thread_id, i4arrnum--);
|
||||
//printf("[0]: %i [%i] : %i\n",adi4buf[thread_id][0], adi4ibuf[thread_id]-1, adi4buf[thread_id][adi4ibuf[thread_id]-1]);
|
||||
}
|
||||
--adi4ibuf[thread_id];
|
||||
*x = adi4buf[thread_id][adi4ibuf[thread_id]];
|
||||
//printf("thread %i popinteger4 %i buff %i\n", thread_id, *x, adi4ibuf[thread_id]);
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* ======================= REAL*8 ========================= */
|
||||
int pushreal8_(double *x)
|
||||
{
|
||||
int thread_id = omp_get_thread_num();
|
||||
|
||||
if (adr8buf[thread_id] == NULL ) {
|
||||
double *buf = (double*)calloc(BUFF_SIZE, sizeof(double));
|
||||
if ( buf == NULL ) {
|
||||
puts("Memory allocation failed.");
|
||||
exit(0);
|
||||
}
|
||||
adr8buf[thread_id] = buf;
|
||||
}
|
||||
adr8buf[thread_id][adr8ibuf[thread_id]] = *x;
|
||||
++adr8ibuf[thread_id];
|
||||
if ( adr8ibuf[thread_id] == BUFF_SIZE) {
|
||||
|
||||
//printf("thread %02i : pushreal8 : pushreal8array : %04i : ", thread_id, ++r8arrnum);
|
||||
//printf("[0]: %f [%i] : %f\n",adr8buf[thread_id][0], adr8ibuf[thread_id]-1, adr8buf[thread_id][adr8ibuf[thread_id]-1]);
|
||||
|
||||
pushreal8array_(adr8buf[thread_id], &c__512);
|
||||
adr8ibuf[thread_id] = 0 ;
|
||||
}
|
||||
//printf("thread %i pushreal8 %f buff %i\n", thread_id, *x,adr8ibuf[thread_id] );
|
||||
return 0;
|
||||
}
|
||||
|
||||
int popreal8_(double *x)
|
||||
{
|
||||
int thread_id = omp_get_thread_num();
|
||||
|
||||
if ( adr8ibuf[thread_id] == 0 ) {
|
||||
popreal8array_(adr8buf[thread_id], &c__512);
|
||||
adr8ibuf[thread_id] = BUFF_SIZE;
|
||||
|
||||
//printf("thread %02i : popreal8 : popreal8array : %04i : ", thread_id, r8arrnum--);
|
||||
//printf("[0]: %f [%i] : %f\n",adr8buf[thread_id][0], adr8ibuf[thread_id]-1, adr8buf[thread_id][adr8ibuf[thread_id]-1]);
|
||||
|
||||
}
|
||||
--adr8ibuf[thread_id];
|
||||
*x = adr8buf[thread_id][adr8ibuf[thread_id]];
|
||||
//printf("thread %i popreal8 %f buff %i\n", thread_id, *x, adr8ibuf[thread_id]);
|
||||
return 0;
|
||||
}
|
||||
|
||||
571
code/new/adStack.c
Normal file
571
code/new/adStack.c
Normal file
@ -0,0 +1,571 @@
|
||||
static char adSid[]="$Id: adStack.c 3723 2011-02-24 13:34:42Z llh $";
|
||||
/*
|
||||
Replac the faulty PUSH/POPs by assignments to/from local arrays,
|
||||
each of them being declared localized to its thread, make it
|
||||
thread-safe for OPENMP.
|
||||
|
||||
If the OPENMP THREAD NUMBER IS GREATER THAN 256 on a single node,
|
||||
the STACK_POOL_SEZE needs to be increased.
|
||||
|
||||
Please beware of this portion that just amended the necessary codes
|
||||
which used by WRFPLUS to make it thread-safe, NOT THE WHOLE CODES.
|
||||
Check it carefully before using for your own case.
|
||||
|
||||
2011-10-10 jliu@ucar.edu
|
||||
|
||||
*/
|
||||
|
||||
#ifndef CRAY
|
||||
# ifdef NOUNDERSCORE
|
||||
# define PUSHINTEGER4ARRAY pushinteger4array
|
||||
# define POPINTEGER4ARRAY popinteger4array
|
||||
# define PUSHREAL8ARRAY pushreal8array
|
||||
# define POPREAL8ARRAY popreal8array
|
||||
# else
|
||||
# define PUSHINTEGER4ARRAY pushinteger4array_
|
||||
# define POPINTEGER4ARRAY popinteger4array_
|
||||
# define PUSHREAL8ARRAY pushreal8array_
|
||||
# define POPREAL8ARRAY popreal8array_
|
||||
# endif
|
||||
#endif
|
||||
|
||||
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <string.h>
|
||||
|
||||
/*
|
||||
#ifdef _OPENMP
|
||||
*/
|
||||
#include <omp.h>
|
||||
#define STACK_POOL_SIZE 256
|
||||
/*
|
||||
#else
|
||||
#define omp_get_thread_num() 0
|
||||
#define STACK_POOL_SIZE 1
|
||||
#endif
|
||||
*/
|
||||
|
||||
#define ONE_BLOCK_SIZE 16384
|
||||
#ifndef STACK_SIZE_TRACING
|
||||
#define STACK_SIZE_TRACING 1
|
||||
#endif
|
||||
/* The main stack is a double-chain of DoubleChainedBlock objects.
|
||||
* Each DoubleChainedBlock holds an array[ONE_BLOCK_SIZE] of char. */
|
||||
typedef struct _doubleChainedBlock{
|
||||
struct _doubleChainedBlock *prev ;
|
||||
char *contents ;
|
||||
struct _doubleChainedBlock *next ;
|
||||
} DoubleChainedBlock ;
|
||||
|
||||
/* Globals that define the current position in the stack: */
|
||||
static DoubleChainedBlock *curStack[STACK_POOL_SIZE] = {NULL} ;
|
||||
static char *curStackTop[STACK_POOL_SIZE] = {NULL} ;
|
||||
/* Globals that define the current LOOKing position in the stack: */
|
||||
static DoubleChainedBlock *lookStack[STACK_POOL_SIZE] = {NULL} ;
|
||||
static char *lookStackTop[STACK_POOL_SIZE] = {NULL} ;
|
||||
|
||||
static long int mmctraffic = 0 ;
|
||||
static long int mmctrafficM = 0 ;
|
||||
#ifdef STACK_SIZE_TRACING
|
||||
long int bigStackSize = 0;
|
||||
#endif
|
||||
|
||||
/* PUSHes "nbChars" consecutive chars from a location starting at address "x".
|
||||
* Resets the LOOKing position if it was active.
|
||||
* Checks that there is enough space left to hold "nbChars" chars.
|
||||
* Otherwise, allocates the necessary space. */
|
||||
void pushNarray(char *x, unsigned int nbChars) {
|
||||
int thread_id = omp_get_thread_num();
|
||||
unsigned int nbmax = (curStack[thread_id])?ONE_BLOCK_SIZE-(curStackTop[thread_id]-(curStack[thread_id]->contents)):0 ;
|
||||
#ifdef STACK_SIZE_TRACING
|
||||
bigStackSize += nbChars;
|
||||
#endif
|
||||
|
||||
mmctraffic += nbChars ;
|
||||
while (mmctraffic >= 1000000) {
|
||||
mmctraffic -= 1000000 ;
|
||||
mmctrafficM++ ;
|
||||
}
|
||||
|
||||
lookStack[thread_id] = NULL ;
|
||||
if (nbChars <= nbmax) {
|
||||
memcpy(curStackTop[thread_id],x,nbChars) ;
|
||||
curStackTop[thread_id]+=nbChars ;
|
||||
} else {
|
||||
char *inx = x+(nbChars-nbmax) ;
|
||||
if (nbmax>0) memcpy(curStackTop[thread_id],inx,nbmax) ;
|
||||
while (inx>x) {
|
||||
if ((curStack[thread_id] == NULL) || (curStack[thread_id]->next == NULL)) {
|
||||
/* Create new block: */
|
||||
DoubleChainedBlock *newStack ;
|
||||
char *contents = (char*)malloc(ONE_BLOCK_SIZE*sizeof(char)) ;
|
||||
newStack = (DoubleChainedBlock*)malloc(sizeof(DoubleChainedBlock)) ;
|
||||
if ((contents == NULL) || (newStack == NULL)) {
|
||||
DoubleChainedBlock *stack = curStack[thread_id] ;
|
||||
int nbBlocks = (stack?-1:0) ;
|
||||
while(stack) {
|
||||
stack = stack->prev ;
|
||||
nbBlocks++ ;
|
||||
}
|
||||
printf("Out of memory (allocated %i blocks of %i bytes)\n",
|
||||
nbBlocks, ONE_BLOCK_SIZE) ;
|
||||
exit(0);
|
||||
}
|
||||
if (curStack[thread_id] != NULL) curStack[thread_id]->next = newStack ;
|
||||
newStack->prev = curStack[thread_id] ;
|
||||
newStack->next = NULL ;
|
||||
newStack->contents = contents ;
|
||||
curStack[thread_id] = newStack ;
|
||||
/* new block created! */
|
||||
} else
|
||||
curStack[thread_id] = curStack[thread_id]->next ;
|
||||
inx -= ONE_BLOCK_SIZE ;
|
||||
if(inx>x)
|
||||
memcpy(curStack[thread_id]->contents,inx,ONE_BLOCK_SIZE) ;
|
||||
else {
|
||||
unsigned int nbhead = (inx-x)+ONE_BLOCK_SIZE ;
|
||||
curStackTop[thread_id] = curStack[thread_id]->contents ;
|
||||
memcpy(curStackTop[thread_id],x,nbhead) ;
|
||||
curStackTop[thread_id] += nbhead ;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* POPs "nbChars" consecutive chars to a location starting at address "x".
|
||||
* Resets the LOOKing position if it was active.
|
||||
* Checks that there is enough data to fill "nbChars" chars.
|
||||
* Otherwise, pops as many blocks as necessary. */
|
||||
void popNarray(char *x, unsigned int nbChars) {
|
||||
int thread_id = omp_get_thread_num();
|
||||
unsigned int nbmax = curStackTop[thread_id]-(curStack[thread_id]->contents) ;
|
||||
#ifdef STACK_SIZE_TRACING
|
||||
bigStackSize -= nbChars;
|
||||
#endif
|
||||
lookStack[thread_id] = NULL ;
|
||||
if (nbChars <= nbmax) {
|
||||
curStackTop[thread_id]-=nbChars ;
|
||||
memcpy(x,curStackTop[thread_id],nbChars);
|
||||
} else {
|
||||
char *tlx = x+nbChars ;
|
||||
if (nbmax>0) memcpy(x,curStack[thread_id]->contents,nbmax) ;
|
||||
x+=nbmax ;
|
||||
while (x<tlx) {
|
||||
curStack[thread_id] = curStack[thread_id]->prev ;
|
||||
if (curStack==NULL) printf("Popping from an empty stack!!!") ;
|
||||
if (x+ONE_BLOCK_SIZE<tlx) {
|
||||
memcpy(x,curStack[thread_id]->contents,ONE_BLOCK_SIZE) ;
|
||||
x += ONE_BLOCK_SIZE ;
|
||||
} else {
|
||||
unsigned int nbtail = tlx-x ;
|
||||
curStackTop[thread_id]=(curStack[thread_id]->contents)+ONE_BLOCK_SIZE-nbtail ;
|
||||
memcpy(x,curStackTop[thread_id],nbtail) ;
|
||||
x = tlx ;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* LOOKs "nbChars" consecutive chars to a location starting at address "x".
|
||||
* Activates the LOOKing position if it was reset.
|
||||
* LOOKing is just like POPping, except that the main pointer
|
||||
* remains in place, so that the value is not POPped.
|
||||
* Further PUSHs or POPs will start from the same place as if
|
||||
* no LOOK had been made. */
|
||||
void lookNarray(char *x, unsigned int nbChars) {
|
||||
int thread_id = omp_get_thread_num();
|
||||
unsigned int nbmax ;
|
||||
if (lookStack[thread_id] == NULL) {
|
||||
lookStack[thread_id] = curStack[thread_id] ;
|
||||
lookStackTop[thread_id] = curStackTop[thread_id] ;
|
||||
}
|
||||
nbmax = lookStackTop[thread_id]-(lookStack[thread_id]->contents) ;
|
||||
if (nbChars <= nbmax) {
|
||||
lookStackTop[thread_id]-=nbChars ;
|
||||
memcpy(x,lookStackTop[thread_id],nbChars);
|
||||
} else {
|
||||
char *tlx = x+nbChars ;
|
||||
if (nbmax>0) memcpy(x,lookStack[thread_id]->contents,nbmax) ;
|
||||
x+=nbmax ;
|
||||
while (x<tlx) {
|
||||
lookStack[thread_id] = lookStack[thread_id]->prev ;
|
||||
if (lookStack[thread_id]==NULL) printf("Looking into an empty stack!!!") ;
|
||||
if (x+ONE_BLOCK_SIZE<tlx) {
|
||||
memcpy(x,lookStack[thread_id]->contents,ONE_BLOCK_SIZE) ;
|
||||
x += ONE_BLOCK_SIZE ;
|
||||
} else {
|
||||
unsigned int nbtail = tlx-x ;
|
||||
lookStackTop[thread_id]=(lookStack[thread_id]->contents)+ONE_BLOCK_SIZE-nbtail ;
|
||||
memcpy(x,lookStackTop[thread_id],nbtail) ;
|
||||
x = tlx ;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
void resetadlookstack_() {
|
||||
int thread_id = omp_get_thread_num();
|
||||
lookStack[thread_id]=NULL ;
|
||||
}
|
||||
|
||||
/****** Exported PUSH/POP/LOOK functions for ARRAYS: ******/
|
||||
|
||||
void pushcharacterarray_(char *x, unsigned int *n) {
|
||||
pushNarray(x,*n) ;
|
||||
}
|
||||
void popcharacterarray_(char *x, unsigned int *n) {
|
||||
popNarray(x,*n) ;
|
||||
}
|
||||
void lookcharacterarray_(char *x, unsigned int *n) {
|
||||
lookNarray(x,*n) ;
|
||||
}
|
||||
|
||||
void pushbooleanarray_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*4)) ;
|
||||
}
|
||||
void popbooleanarray_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*4)) ;
|
||||
}
|
||||
void lookbooleanarray_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*4)) ;
|
||||
}
|
||||
|
||||
void PUSHINTEGER4ARRAY(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*4)) ;
|
||||
}
|
||||
void POPINTEGER4ARRAY(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*4)) ;
|
||||
}
|
||||
void lookinteger4array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*4)) ;
|
||||
}
|
||||
|
||||
void pushinteger8array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*8)) ;
|
||||
}
|
||||
void popinteger8array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*8)) ;
|
||||
}
|
||||
void lookinteger8array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*8)) ;
|
||||
}
|
||||
|
||||
void pushinteger16array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*16)) ;
|
||||
}
|
||||
void popinteger16array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*16)) ;
|
||||
}
|
||||
void lookinteger16array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*16)) ;
|
||||
}
|
||||
|
||||
void pushreal4array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*4)) ;
|
||||
}
|
||||
void popreal4array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*4)) ;
|
||||
}
|
||||
void lookreal4array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*4)) ;
|
||||
}
|
||||
|
||||
void PUSHREAL8ARRAY(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*8)) ;
|
||||
}
|
||||
void POPREAL8ARRAY(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*8)) ;
|
||||
}
|
||||
void lookreal8array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*8)) ;
|
||||
}
|
||||
|
||||
void pushreal16array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*16)) ;
|
||||
}
|
||||
void popreal16array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*16)) ;
|
||||
}
|
||||
void lookreal16array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*16)) ;
|
||||
}
|
||||
|
||||
void pushreal32array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*32)) ;
|
||||
}
|
||||
void popreal32array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*32)) ;
|
||||
}
|
||||
void lookreal32array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*32)) ;
|
||||
}
|
||||
|
||||
void pushcomplex4array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*4)) ;
|
||||
}
|
||||
void popcomplex4array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*4)) ;
|
||||
}
|
||||
void lookcomplex4array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*4)) ;
|
||||
}
|
||||
|
||||
void pushcomplex8array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*8)) ;
|
||||
}
|
||||
void popcomplex8array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*8)) ;
|
||||
}
|
||||
void lookcomplex8array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*8)) ;
|
||||
}
|
||||
|
||||
void pushcomplex16array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*16)) ;
|
||||
}
|
||||
void popcomplex16array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*16)) ;
|
||||
}
|
||||
void lookcomplex16array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*16)) ;
|
||||
}
|
||||
|
||||
void pushcomplex32array_(char *x, unsigned int *n) {
|
||||
pushNarray(x,(*n*32)) ;
|
||||
}
|
||||
void popcomplex32array_(char *x, unsigned int *n) {
|
||||
popNarray(x,(*n*32)) ;
|
||||
}
|
||||
void lookcomplex32array_(char *x, unsigned int *n) {
|
||||
lookNarray(x,(*n*32)) ;
|
||||
}
|
||||
|
||||
/****** Exported PUSH/POP/LOOK functions for F95 POINTERS: ******/
|
||||
|
||||
/* IMPORTANT: Don't forget to add the following interface into each calling routines:
|
||||
|
||||
INTERFACE
|
||||
SUBROUTINE PUSHPOINTER(pp)
|
||||
REAL, POINTER :: pp
|
||||
END SUBROUTINE PUSHPOINTER
|
||||
SUBROUTINE POPPOINTER(pp)
|
||||
REAL, POINTER :: pp
|
||||
END SUBROUTINE POPPOINTER
|
||||
END INTERFACE
|
||||
|
||||
*/
|
||||
|
||||
void pushpointer_(char *ppp) {
|
||||
pushNarray(ppp, 4) ;
|
||||
}
|
||||
|
||||
void poppointer_(char *ppp) {
|
||||
popNarray(ppp, 4) ;
|
||||
}
|
||||
|
||||
|
||||
/************* Debug displays of the state of the stack: ***********/
|
||||
|
||||
void printbigbytes(long int nbblocks, long int blocksz, long int nbunits) {
|
||||
long int a3, b3, res3, res6, res9, res12 ;
|
||||
int a0, b0, res0 ;
|
||||
int printzeros = 0 ;
|
||||
a0 = (int)nbblocks%1000 ;
|
||||
a3 = nbblocks/1000 ;
|
||||
b0 = (int)blocksz%1000 ;
|
||||
b3 = blocksz/1000 ;
|
||||
res0 = ((int)(nbunits%1000)) + a0*b0 ;
|
||||
res3 = nbunits/1000 + a3*b0 + a0*b3 ;
|
||||
res6 = a3*b3 ;
|
||||
res3 += ((long int)(res0/1000)) ;
|
||||
res0 = res0%1000 ;
|
||||
res6 += res3/1000 ;
|
||||
res3 = res3%1000 ;
|
||||
res9 = res6/1000 ;
|
||||
res6 = res6%1000 ;
|
||||
res12 = res9/1000 ;
|
||||
res9 = res9%1000 ;
|
||||
if (res12>0) {
|
||||
printf("%li ", res12) ;
|
||||
printzeros = 1 ;
|
||||
}
|
||||
if ((res9/100)>0 || printzeros) {
|
||||
printf("%li",res9/100) ;
|
||||
printzeros = 1 ;
|
||||
res9 = res9%100 ;
|
||||
}
|
||||
if ((res9/10)>0 || printzeros) {
|
||||
printf("%li",res9/10) ;
|
||||
printzeros = 1 ;
|
||||
res9 = res9%10 ;
|
||||
}
|
||||
if (res9>0 || printzeros) {
|
||||
printf("%li ",res9) ;
|
||||
printzeros = 1 ;
|
||||
}
|
||||
if ((res6/100)>0 || printzeros) {
|
||||
printf("%li",res6/100) ;
|
||||
printzeros = 1 ;
|
||||
res6 = res6%100 ;
|
||||
}
|
||||
if ((res6/10)>0 || printzeros) {
|
||||
printf("%li",res6/10) ;
|
||||
printzeros = 1 ;
|
||||
res6 = res6%10 ;
|
||||
}
|
||||
if (res6>0 || printzeros) {
|
||||
printf("%li ",res6) ;
|
||||
printzeros = 1 ;
|
||||
}
|
||||
if ((res3/100)>0 || printzeros) {
|
||||
printf("%li",res3/100) ;
|
||||
printzeros = 1 ;
|
||||
res3 = res3%100 ;
|
||||
}
|
||||
if ((res3/10)>0 || printzeros) {
|
||||
printf("%li",res3/10) ;
|
||||
printzeros = 1 ;
|
||||
res3 = res3%10 ;
|
||||
}
|
||||
if (res3>0 || printzeros) {
|
||||
printf("%li ",res3) ;
|
||||
printzeros = 1 ;
|
||||
}
|
||||
if ((res0/100)>0 || printzeros) {
|
||||
printf("%i",res0/100) ;
|
||||
printzeros = 1 ;
|
||||
res0 = res0%100 ;
|
||||
}
|
||||
if ((res0/10)>0 || printzeros) {
|
||||
printf("%i",res0/10) ;
|
||||
printzeros = 1 ;
|
||||
res0 = res0%10 ;
|
||||
}
|
||||
printf("%i",res0) ;
|
||||
}
|
||||
|
||||
void printctraffic_() {
|
||||
printf(" C Traffic: ") ;
|
||||
printbigbytes(mmctrafficM, 1000000, mmctraffic) ;
|
||||
printf(" bytes\n") ;
|
||||
}
|
||||
|
||||
void printftrafficinc_(long int *mmfM, int *mmfsz, int *mmf) {
|
||||
printf(" F Traffic: ") ;
|
||||
printbigbytes(*mmfM, (long int)*mmfsz, (long int)*mmf) ;
|
||||
printf(" bytes\n") ;
|
||||
}
|
||||
|
||||
void printtopplace_() {
|
||||
int thread_id = omp_get_thread_num();
|
||||
DoubleChainedBlock *stack = curStack[thread_id] ;
|
||||
int nbBlocks = (stack?-1:0) ;
|
||||
int remainder = 0;
|
||||
while(stack) {
|
||||
stack = stack->prev ;
|
||||
nbBlocks++ ;
|
||||
}
|
||||
if (curStack[thread_id] && curStackTop[thread_id]) remainder = curStackTop[thread_id]-(curStack[thread_id]->contents) ;
|
||||
printf(" Stack size: ") ;
|
||||
printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)remainder) ;
|
||||
printf(" bytes\n") ;
|
||||
}
|
||||
|
||||
void printtopplacenum_(int *n) {
|
||||
int thread_id = omp_get_thread_num();
|
||||
DoubleChainedBlock *stack = curStack[thread_id] ;
|
||||
int nbBlocks = (stack?-1:0) ;
|
||||
int remainder = 0;
|
||||
while(stack) {
|
||||
stack = stack->prev ;
|
||||
nbBlocks++ ;
|
||||
}
|
||||
if (curStack[thread_id] && curStackTop[thread_id]) remainder = curStackTop[thread_id]-(curStack[thread_id]->contents) ;
|
||||
printf(" Stack size at location %i : ", *n) ;
|
||||
printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)remainder) ;
|
||||
printf(" bytes\n") ;
|
||||
}
|
||||
|
||||
void printstackmax_() {
|
||||
int thread_id = omp_get_thread_num();
|
||||
DoubleChainedBlock *stack = curStack[thread_id] ;
|
||||
int nbBlocks = (stack?-2:0) ;
|
||||
int remainder = 0;
|
||||
long int totalsz ;
|
||||
while(stack) {
|
||||
stack = stack->prev ;
|
||||
nbBlocks++ ;
|
||||
}
|
||||
stack = curStack[thread_id] ;
|
||||
while(stack) {
|
||||
stack = stack->next ;
|
||||
nbBlocks++ ;
|
||||
}
|
||||
|
||||
printf(" Max Stack size (%i blocks): ", nbBlocks) ;
|
||||
printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE, (long int)0) ;
|
||||
printf(" bytes\n") ;
|
||||
}
|
||||
|
||||
void printlookingplace_() {
|
||||
int thread_id = omp_get_thread_num();
|
||||
if (lookStack[thread_id] == NULL)
|
||||
printtopplace_() ;
|
||||
else {
|
||||
DoubleChainedBlock *stack = lookStack[thread_id] ;
|
||||
int nbBlocks = (stack?-1:0) ;
|
||||
while(stack) {
|
||||
stack = stack->prev ;
|
||||
nbBlocks++ ;
|
||||
}
|
||||
printf(" Stack look at: ") ;
|
||||
printbigbytes((long int)nbBlocks, ONE_BLOCK_SIZE,
|
||||
((long int)(lookStackTop[thread_id]-(lookStack[thread_id]->contents)))) ;
|
||||
printf(" bytes\n") ;
|
||||
}
|
||||
}
|
||||
|
||||
void showrecentcstack_() {
|
||||
int thread_id = omp_get_thread_num();
|
||||
if (curStack[thread_id] && curStackTop[thread_id]) {
|
||||
int totalNumChars = 30 ;
|
||||
DoubleChainedBlock *stack = curStack[thread_id] ;
|
||||
char *stackTop = curStackTop[thread_id] ;
|
||||
unsigned short int *st1 ;
|
||||
printf("TOP OF C STACK : ") ;
|
||||
while (totalNumChars>0 && stackTop>(stack->contents)) {
|
||||
stackTop-- ;
|
||||
st1 = (unsigned short int *)stackTop ;
|
||||
printf("%02X,",*st1%256) ;
|
||||
totalNumChars-- ;
|
||||
}
|
||||
while (totalNumChars>0 && stack->prev) {
|
||||
printf(" || ") ;
|
||||
stack = stack->prev ;
|
||||
stackTop = (stack->contents)+ONE_BLOCK_SIZE ;
|
||||
while (totalNumChars>0 && stackTop>(stack->contents)) {
|
||||
stackTop-- ;
|
||||
st1 = (unsigned short int *)stackTop ;
|
||||
printf("%02X,",*st1%256) ;
|
||||
totalNumChars-- ;
|
||||
}
|
||||
}
|
||||
if (stack->prev || stackTop>(stack->contents))
|
||||
printf(" ...\n") ;
|
||||
else
|
||||
printf(" || BOTTOM\n") ;
|
||||
} else {
|
||||
printf("NOTHING IN C STACK.\n") ;
|
||||
}
|
||||
}
|
||||
|
||||
void getnbblocksinstack_(int *nbblocks) {
|
||||
int thread_id = omp_get_thread_num();
|
||||
DoubleChainedBlock *stack = curStack[thread_id] ;
|
||||
*nbblocks = 0 ;
|
||||
while(stack) {
|
||||
stack = stack->prev ;
|
||||
(*nbblocks)++ ;
|
||||
}
|
||||
}
|
||||
261
code/new/blas.f
Normal file
261
code/new/blas.f
Normal file
@ -0,0 +1,261 @@
|
||||
c
|
||||
c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License”
|
||||
c or “3-clause license”)
|
||||
c Please read attached file License.txt
|
||||
c
|
||||
|
||||
double precision function dnrm2(n,x,incx)
|
||||
integer n,incx
|
||||
double precision x(n)
|
||||
c **********
|
||||
c
|
||||
c Function dnrm2
|
||||
c
|
||||
c Given a vector x of length n, this function calculates the
|
||||
c Euclidean norm of x with stride incx.
|
||||
c
|
||||
c The function statement is
|
||||
c
|
||||
c double precision function dnrm2(n,x,incx)
|
||||
c
|
||||
c where
|
||||
c
|
||||
c n is a positive integer input variable.
|
||||
c
|
||||
c x is an input array of length n.
|
||||
c
|
||||
c incx is a positive integer variable that specifies the
|
||||
c stride of the vector.
|
||||
c
|
||||
c Subprograms called
|
||||
c
|
||||
c FORTRAN-supplied ... abs, max, sqrt
|
||||
c
|
||||
c MINPACK-2 Project. February 1991.
|
||||
c Argonne National Laboratory.
|
||||
c Brett M. Averick.
|
||||
c
|
||||
c **********
|
||||
integer i
|
||||
double precision scale
|
||||
|
||||
dnrm2 = 0.0d0
|
||||
scale = 0.0d0
|
||||
|
||||
do 10 i = 1, n, incx
|
||||
scale = max(scale, abs(x(i)))
|
||||
10 continue
|
||||
|
||||
if (scale .eq. 0.0d0) return
|
||||
|
||||
do 20 i = 1, n, incx
|
||||
dnrm2 = dnrm2 + (x(i)/scale)**2
|
||||
20 continue
|
||||
|
||||
dnrm2 = scale*sqrt(dnrm2)
|
||||
|
||||
|
||||
return
|
||||
|
||||
end
|
||||
|
||||
c====================== The end of dnrm2 ===============================
|
||||
|
||||
subroutine daxpy(n,da,dx,incx,dy,incy)
|
||||
c
|
||||
c constant times a vector plus a vector.
|
||||
c uses unrolled loops for increments equal to one.
|
||||
c jack dongarra, linpack, 3/11/78.
|
||||
c
|
||||
double precision dx(*),dy(*),da
|
||||
integer i,incx,incy,ix,iy,m,mp1,n
|
||||
c
|
||||
if(n.le.0)return
|
||||
if (da .eq. 0.0d0) return
|
||||
if(incx.eq.1.and.incy.eq.1)go to 20
|
||||
c
|
||||
c code for unequal increments or equal increments
|
||||
c not equal to 1
|
||||
c
|
||||
ix = 1
|
||||
iy = 1
|
||||
if(incx.lt.0)ix = (-n+1)*incx + 1
|
||||
if(incy.lt.0)iy = (-n+1)*incy + 1
|
||||
do 10 i = 1,n
|
||||
dy(iy) = dy(iy) + da*dx(ix)
|
||||
ix = ix + incx
|
||||
iy = iy + incy
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for both increments equal to 1
|
||||
c
|
||||
c
|
||||
c clean-up loop
|
||||
c
|
||||
20 m = mod(n,4)
|
||||
if( m .eq. 0 ) go to 40
|
||||
do 30 i = 1,m
|
||||
dy(i) = dy(i) + da*dx(i)
|
||||
30 continue
|
||||
if( n .lt. 4 ) return
|
||||
40 mp1 = m + 1
|
||||
do 50 i = mp1,n,4
|
||||
dy(i) = dy(i) + da*dx(i)
|
||||
dy(i + 1) = dy(i + 1) + da*dx(i + 1)
|
||||
dy(i + 2) = dy(i + 2) + da*dx(i + 2)
|
||||
dy(i + 3) = dy(i + 3) + da*dx(i + 3)
|
||||
50 continue
|
||||
return
|
||||
end
|
||||
|
||||
c====================== The end of daxpy ===============================
|
||||
|
||||
subroutine dcopy(n,dx,incx,dy,incy)
|
||||
c
|
||||
c copies a vector, x, to a vector, y.
|
||||
c uses unrolled loops for increments equal to one.
|
||||
c jack dongarra, linpack, 3/11/78.
|
||||
c
|
||||
double precision dx(*),dy(*)
|
||||
integer i,incx,incy,ix,iy,m,mp1,n
|
||||
c
|
||||
if(n.le.0)return
|
||||
if(incx.eq.1.and.incy.eq.1)go to 20
|
||||
c
|
||||
c code for unequal increments or equal increments
|
||||
c not equal to 1
|
||||
c
|
||||
ix = 1
|
||||
iy = 1
|
||||
if(incx.lt.0)ix = (-n+1)*incx + 1
|
||||
if(incy.lt.0)iy = (-n+1)*incy + 1
|
||||
do 10 i = 1,n
|
||||
dy(iy) = dx(ix)
|
||||
ix = ix + incx
|
||||
iy = iy + incy
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for both increments equal to 1
|
||||
c
|
||||
c
|
||||
c clean-up loop
|
||||
c
|
||||
20 m = mod(n,7)
|
||||
if( m .eq. 0 ) go to 40
|
||||
do 30 i = 1,m
|
||||
dy(i) = dx(i)
|
||||
30 continue
|
||||
if( n .lt. 7 ) return
|
||||
40 mp1 = m + 1
|
||||
do 50 i = mp1,n,7
|
||||
dy(i) = dx(i)
|
||||
dy(i + 1) = dx(i + 1)
|
||||
dy(i + 2) = dx(i + 2)
|
||||
dy(i + 3) = dx(i + 3)
|
||||
dy(i + 4) = dx(i + 4)
|
||||
dy(i + 5) = dx(i + 5)
|
||||
dy(i + 6) = dx(i + 6)
|
||||
50 continue
|
||||
return
|
||||
end
|
||||
|
||||
c====================== The end of dcopy ===============================
|
||||
|
||||
double precision function ddot(n,dx,incx,dy,incy)
|
||||
c
|
||||
c forms the dot product of two vectors.
|
||||
c uses unrolled loops for increments equal to one.
|
||||
c jack dongarra, linpack, 3/11/78.
|
||||
c
|
||||
double precision dx(*),dy(*),dtemp
|
||||
integer i,incx,incy,ix,iy,m,mp1,n
|
||||
c
|
||||
ddot = 0.0d0
|
||||
dtemp = 0.0d0
|
||||
if(n.le.0)return
|
||||
if(incx.eq.1.and.incy.eq.1)go to 20
|
||||
c
|
||||
c code for unequal increments or equal increments
|
||||
c not equal to 1
|
||||
c
|
||||
ix = 1
|
||||
iy = 1
|
||||
if(incx.lt.0)ix = (-n+1)*incx + 1
|
||||
if(incy.lt.0)iy = (-n+1)*incy + 1
|
||||
do 10 i = 1,n
|
||||
dtemp = dtemp + dx(ix)*dy(iy)
|
||||
ix = ix + incx
|
||||
iy = iy + incy
|
||||
10 continue
|
||||
ddot = dtemp
|
||||
return
|
||||
c
|
||||
c code for both increments equal to 1
|
||||
c
|
||||
c
|
||||
c clean-up loop
|
||||
c
|
||||
20 m = mod(n,5)
|
||||
if( m .eq. 0 ) go to 40
|
||||
do 30 i = 1,m
|
||||
dtemp = dtemp + dx(i)*dy(i)
|
||||
30 continue
|
||||
if( n .lt. 5 ) go to 60
|
||||
40 mp1 = m + 1
|
||||
do 50 i = mp1,n,5
|
||||
dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
|
||||
* dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
|
||||
50 continue
|
||||
60 ddot = dtemp
|
||||
return
|
||||
end
|
||||
|
||||
c====================== The end of ddot ================================
|
||||
|
||||
subroutine dscal(n,da,dx,incx)
|
||||
c
|
||||
c scales a vector by a constant.
|
||||
c uses unrolled loops for increment equal to one.
|
||||
c jack dongarra, linpack, 3/11/78.
|
||||
c modified 3/93 to return if incx .le. 0.
|
||||
c
|
||||
double precision da,dx(*)
|
||||
integer i,incx,m,mp1,n,nincx
|
||||
c
|
||||
if( n.le.0 .or. incx.le.0 )return
|
||||
if(incx.eq.1)go to 20
|
||||
c
|
||||
c code for increment not equal to 1
|
||||
c
|
||||
nincx = n*incx
|
||||
do 10 i = 1,nincx,incx
|
||||
dx(i) = da*dx(i)
|
||||
10 continue
|
||||
return
|
||||
c
|
||||
c code for increment equal to 1
|
||||
c
|
||||
c
|
||||
c clean-up loop
|
||||
c
|
||||
20 m = mod(n,5)
|
||||
if( m .eq. 0 ) go to 40
|
||||
do 30 i = 1,m
|
||||
dx(i) = da*dx(i)
|
||||
30 continue
|
||||
if( n .lt. 5 ) return
|
||||
40 mp1 = m + 1
|
||||
do 50 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)
|
||||
50 continue
|
||||
return
|
||||
end
|
||||
|
||||
c====================== The end of dscal ===============================
|
||||
|
||||
1845
code/new/isoropiaII_adj_mod.f
Normal file
1845
code/new/isoropiaII_adj_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
32408
code/new/isoropiaIIcode_adj.f
Normal file
32408
code/new/isoropiaIIcode_adj.f
Normal file
File diff suppressed because it is too large
Load Diff
551
code/new/isrpia_adj.inc
Normal file
551
code/new/isrpia_adj.inc
Normal file
@ -0,0 +1,551 @@
|
||||
!=======================================================================
|
||||
! File "isrpia_adj.inc" contains the common block declarations and some
|
||||
! parameters for the ISORROPIAII code. This file replaces "isoropia.h" from
|
||||
! previous ISORROPIA implementations.
|
||||
! ( hotp 8/1/07 )
|
||||
! ( previous implementation: bec, bmy, 3/7/05, 6/28/06 )
|
||||
!
|
||||
! Please contact the original authors before making modifications to
|
||||
! ISOROPIAII.
|
||||
!
|
||||
! *** VERY IMPORTANT PORTING WARNING (slc.1.2012) ***
|
||||
! ANISORROPIA code is optimized for adjoint frameworks and will not
|
||||
! perform commensurately with publicly released ISORROPIAII code.
|
||||
!
|
||||
! Please visit http://nenes.eas.gatech.edu/ISORROPIA for current
|
||||
! releases of ISORROPIAII for forward modeling.
|
||||
!
|
||||
! Original Documentation:
|
||||
! *** ISORROPIA CODE II
|
||||
! *** INCLUDE FILE 'ISRPIA.INC'
|
||||
! *** THIS FILE CONTAINS THE DECLARATIONS OF THE GLOBAL CONSTANTS
|
||||
! AND VARIABLES.
|
||||
!
|
||||
! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
||||
! *** GEORGIA INSTITUTE OF TECHNOLOGY
|
||||
! *** WRITTEN BY ATHANASIOS NENES
|
||||
! *** UPDATED BY CHRISTOS FOUNTOUKIS
|
||||
! *** ADJOINT & UPDATE BY SHANNON CAPPS
|
||||
!
|
||||
! NOTES:
|
||||
! (1 ) Renamed common block GAS to GASCB to avoid confusion with array
|
||||
! GAS in isoropiaIIcode.f (hotp)
|
||||
! (2 ) Explicity declared all variables in this file (hotp)
|
||||
! (3 ) Separated common blocks so that each block has only one type of data (hotp)
|
||||
! (4 ) Declared all common blocks (except READ-ONLY blocks) as
|
||||
! THREADPRIVATE (hotp)
|
||||
! (5 ) Divided common blocks so that each has no more than 8 variables
|
||||
! (this is to speed compilation) (hotp)
|
||||
! (6 ) Divided common blocks so that READ-ONLY variables are not mixed with
|
||||
! variables that are modified (hotp)
|
||||
! (7 ) Removed DRYF since it is not used (hotp)
|
||||
! (8 ) Bug fix: CRRAT was being truncated at column 72 (hotp, bmy, 6/1/10)
|
||||
! (9 ) IONIC should be REAL*8 for consistency with -r8 flag during
|
||||
! compiling of isoropiaIIcode routines (hotp, bmy, 6/28/10)
|
||||
! 22 Aug 2011 - S. Capps - ANISORROPIA implementation
|
||||
!=======================================================================
|
||||
!
|
||||
!=======================================================================
|
||||
!
|
||||
! *** ISORROPIA CODE
|
||||
! *** INCLUDE FILE 'ISRPIA_ADJ.INC'
|
||||
! *** THIS FILE CONTAINS THE DECLARATIONS OF THE GLOBAL CONSTANTS
|
||||
! AND VARIABLES.
|
||||
!
|
||||
! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY,
|
||||
! *** GEORGIA INSTITUTE OF TECHNOLOGY
|
||||
! *** WRITTEN BY ATHANASIOS NENES
|
||||
! *** UPDATED BY CHRISTOS FOUNTOUKIS
|
||||
!
|
||||
!=======================================================================
|
||||
!
|
||||
! leave this implicit statement for isoropiaIIcode.f variables
|
||||
! ideally all variables would be declared
|
||||
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
|
||||
|
||||
! INTEGER parameters
|
||||
INTEGER, PARAMETER :: NCOMP = 8
|
||||
INTEGER, PARAMETER :: NERRMX = 25
|
||||
INTEGER, PARAMETER :: NGASAQ = 3
|
||||
INTEGER, PARAMETER :: NIONS = 10
|
||||
INTEGER, PARAMETER :: NPAIR = 23
|
||||
INTEGER, PARAMETER :: NSLDS = 19
|
||||
INTEGER, PARAMETER :: NZSR = 100
|
||||
|
||||
!=================================================================
|
||||
! Input variables
|
||||
!=================================================================
|
||||
|
||||
INTEGER :: METSTBL = 0
|
||||
INTEGER :: IPROB = 0
|
||||
COMMON /INPT/ IPROB, METSTBL
|
||||
!$OMP THREADPRIVATE( /INPT/ )
|
||||
|
||||
INTEGER :: NADJ = 0
|
||||
COMMON /INPT2/ NADJ
|
||||
! INPT2 is read-only
|
||||
|
||||
REAL*8 :: W(NCOMP), WAER(NCOMP)
|
||||
REAL*8 :: TEMP = 298.d0
|
||||
REAL*8 :: RH = 0.9D0
|
||||
COMMON /INPT3/ W, WAER, TEMP, RH
|
||||
!$OMP THREADPRIVATE( /INPT3/ )
|
||||
|
||||
!=================================================================
|
||||
! Water activities of pure salt solutions
|
||||
!=================================================================
|
||||
|
||||
! /ZSR/ is read-only and doesn't have to be declared THREADPRIVATE
|
||||
! block does not need to be split up to speed compilation
|
||||
REAL*8 :: AWAS(NZSR), AWSS(NZSR), AWAC(NZSR), AWSC(NZSR)
|
||||
REAL*8 :: AWAN(NZSR), AWSN(NZSR), AWSB(NZSR), AWAB(NZSR)
|
||||
REAL*8 :: AWSA(NZSR), AWLC(NZSR), AWCS(NZSR), AWCN(NZSR)
|
||||
REAL*8 :: AWCC(NZSR), AWPS(NZSR), AWPB(NZSR), AWPN(NZSR)
|
||||
REAL*8 :: AWPC(NZSR), AWMS(NZSR), AWMN(NZSR), AWMC(NZSR)
|
||||
COMMON /ZSR / AWAS, AWSS, AWAC, AWSC,
|
||||
& AWAN, AWSN, AWSB, AWAB,
|
||||
& AWSA, AWLC, AWCS, AWCN,
|
||||
& AWCC, AWPS, AWPB, AWPN,
|
||||
& AWPC, AWMS, AWMN, AWMC
|
||||
! ZSR is read-only
|
||||
|
||||
!=================================================================
|
||||
! Deliquescence relative humidities
|
||||
!=================================================================
|
||||
|
||||
INTEGER :: WFTYP
|
||||
COMMON /WFT/ WFTYP
|
||||
! WFTYP is read-only
|
||||
|
||||
REAL*8 :: DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3
|
||||
REAL*8 :: DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL
|
||||
REAL*8 :: DRCASO4, DRCANO32, DRCACL2, DRK2SO4, DRKHSO4
|
||||
REAL*8 :: DRKNO3, DRKCL, DRMGSO4, DRMGNO32, DRMGCL2
|
||||
COMMON /DRH / DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3
|
||||
COMMON /DRH2/ DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL
|
||||
COMMON /DRH3/ DRCASO4, DRCANO32, DRCACL2, DRK2SO4, DRKHSO4
|
||||
COMMON /DRH4/ DRKNO3, DRKCL, DRMGSO4, DRMGNO32, DRMGCL2
|
||||
!$OMP THREADPRIVATE( /DRH/ )
|
||||
!$OMP THREADPRIVATE( /DRH2/ )
|
||||
!$OMP THREADPRIVATE( /DRH3/ )
|
||||
!$OMP THREADPRIVATE( /DRH4/ )
|
||||
|
||||
REAL*8 :: DRMLCAB, DRMLCAS, DRMASAN, DRMG1, DRMG2
|
||||
REAL*8 :: DRMG3, DRMH1, DRMH2, DRMI1, DRMI2
|
||||
REAL*8 :: DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3
|
||||
REAL*8 :: DRMR4, DRMR5, DRMR6, DRMR7, DRMR8
|
||||
REAL*8 :: DRMR9, DRMR10, DRMR11, DRMR12, DRMR13
|
||||
COMMON /MDRH/ DRMLCAB, DRMLCAS, DRMASAN, DRMG1, DRMG2
|
||||
COMMON /MDRH2/ DRMG3, DRMH1, DRMH2, DRMI1, DRMI2
|
||||
COMMON /MDRH3/ DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3
|
||||
COMMON /MDRH4/ DRMR4, DRMR5, DRMR6, DRMR7, DRMR8
|
||||
COMMON /MDRH5/ DRMR9, DRMR10, DRMR11, DRMR12, DRMR13
|
||||
!$OMP THREADPRIVATE( /MDRH/ )
|
||||
!$OMP THREADPRIVATE( /MDRH2/ )
|
||||
!$OMP THREADPRIVATE( /MDRH3/ )
|
||||
!$OMP THREADPRIVATE( /MDRH4/ )
|
||||
!$OMP THREADPRIVATE( /MDRH5/ )
|
||||
|
||||
REAL*8 :: DRMO1, DRMO2, DRMO3, DRML1, DRML2
|
||||
REAL*8 :: DRML3, DRMM1, DRMM2, DRMP1, DRMP2
|
||||
REAL*8 :: DRMP3, DRMP4, DRMP5, DRMV1
|
||||
COMMON /MDRH6/ DRMO1, DRMO2, DRMO3, DRML1, DRML2
|
||||
COMMON /MDRH7/ DRML3, DRMM1, DRMM2, DRMP1, DRMP2
|
||||
COMMON /MDRH8/ DRMP3, DRMP4, DRMP5, DRMV1
|
||||
!$OMP THREADPRIVATE( /MDRH6/ )
|
||||
!$OMP THREADPRIVATE( /MDRH7/ )
|
||||
!$OMP THREADPRIVATE( /MDRH8/ )
|
||||
|
||||
!=================================================================
|
||||
! Variables for liquid aerosol phase
|
||||
!=================================================================
|
||||
|
||||
! /IONS/ size does not seem to slow compilation
|
||||
REAL*8 :: MOLAL(NIONS) = 0.0D0
|
||||
REAL*8 :: MOLALR(NPAIR) = 0.0D0
|
||||
REAL*8 :: M0(NPAIR) = 1.0d5
|
||||
REAL*8 :: GAMA(NPAIR) = NPAIR*0.1D0
|
||||
REAL*8 :: GAMOU(NPAIR) = NPAIR*1.D10
|
||||
REAL*8 :: GAMIN(NPAIR) = NPAIR*1.D10
|
||||
REAL*8 :: GASAQ(NGASAQ) = 0.0D0
|
||||
REAL*8 :: COH = 0.d0
|
||||
REAL*8 :: CHNO3 = 0.d0
|
||||
REAL*8 :: CHCL = 0.d0
|
||||
REAL*8 :: WATER = 1.d-20
|
||||
COMMON /IONS/ MOLAL, MOLALR, M0,
|
||||
& GAMA,
|
||||
& GAMOU, GAMIN, GASAQ,
|
||||
& COH, CHNO3, CHCL,
|
||||
& WATER
|
||||
!$OMP THREADPRIVATE( /IONS/ )
|
||||
|
||||
REAL*8 :: ZZ(NPAIR) = (/ 1,2,1,2,1,1,2,1,1,1,1,1,2,4,2,2,2,
|
||||
& 1,1,1,4,2,2 /)
|
||||
REAL*8 :: Z(NIONS) = (/ 1.0D0, 1.0D0, 1.0D0, 1.0D0, 2.0D0,
|
||||
& 1.0D0, 1.0D0, 2.0D0, 1.0D0, 2.0D0 /)
|
||||
REAL*8 :: EPSACT = 5D-2
|
||||
COMMON /IONS2/ ZZ, Z, EPSACT
|
||||
! IONS2 is read-only
|
||||
|
||||
!----------------------------------------------------------------------
|
||||
! Prior to 6/28/10:
|
||||
! IONIC should be REAL*8 for consistency with -r8 flag during
|
||||
! compiling of isoropiaIIcode routines (hotp 6/23/10)
|
||||
!REAL*4 :: IONIC
|
||||
!----------------------------------------------------------------------
|
||||
REAL*8 :: IONIC = 0.d0
|
||||
COMMON /IONS3/ IONIC
|
||||
!$OMP THREADPRIVATE( /IONS3/ )
|
||||
|
||||
! DRYF removed since it is not used (hotp)
|
||||
LOGICAL :: CALAOU = .TRUE.
|
||||
LOGICAL :: CALAIN = .TRUE.
|
||||
LOGICAL :: FRST = .TRUE.
|
||||
COMMON /IONS4/ CALAOU, CALAIN, FRST
|
||||
!$OMP THREADPRIVATE( /IONS4/ )
|
||||
|
||||
INTEGER :: IACALC = 0
|
||||
COMMON /IONS5/ IACALC
|
||||
! IONS5 is read-only
|
||||
!=================================================================
|
||||
! Variables for solid aerosol phase
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4
|
||||
REAL*8 :: CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC, CCASO4
|
||||
REAL*8 :: CCANO32, CCACL2, CK2SO4, CKHSO4, CKNO3, CKCL
|
||||
REAL*8 :: CMGSO4, CMGNO32, CMGCL2
|
||||
COMMON /SALT/ CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4
|
||||
COMMON /SALT2/ CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC, CCASO4
|
||||
COMMON /SALT3/ CCANO32, CCACL2, CK2SO4, CKHSO4, CKNO3, CKCL
|
||||
COMMON /SALT4/ CMGSO4, CMGNO32, CMGCL2
|
||||
!$OMP THREADPRIVATE( /SALT/ )
|
||||
!$OMP THREADPRIVATE( /SALT2/ )
|
||||
!$OMP THREADPRIVATE( /SALT3/ )
|
||||
!$OMP THREADPRIVATE( /SALT4/ )
|
||||
|
||||
!=================================================================
|
||||
! Variables for gas phase
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: GNH3, GHNO3, GHCL
|
||||
COMMON /GASCB/ GNH3, GHNO3, GHCL
|
||||
!$OMP THREADPRIVATE( /GASCB/ )
|
||||
|
||||
!=================================================================
|
||||
! Equilibrium constants
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10
|
||||
REAL*8 :: XK11,XK12,XK13,XK14,XKW, XK21,XK22,XK31,XK32,XK41
|
||||
REAL*8 :: XK42,XK15,XK16,XK17,XK18,XK19,XK20,XK23
|
||||
REAL*8 :: XK24,XK25
|
||||
COMMON /EQUK/ XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10
|
||||
COMMON /EQUK2/ XK11,XK12,XK13,XK14,XKW, XK21,XK22,XK31,XK32,XK41
|
||||
COMMON /EQUK3/ XK42,XK15,XK16,XK17,XK18,XK19,XK20,XK23
|
||||
COMMON /EQUK4/ XK24,XK25
|
||||
!C & , XK26, XK27
|
||||
!$OMP THREADPRIVATE( /EQUK/ )
|
||||
!$OMP THREADPRIVATE( /EQUK2/ )
|
||||
!$OMP THREADPRIVATE( /EQUK3/ )
|
||||
!$OMP THREADPRIVATE( /EQUK4/ )
|
||||
|
||||
!=================================================================
|
||||
! Molecular Weights
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: R = 82.0567D-6
|
||||
REAL*8 :: IMW(NIONS) = (/ 1.0, 23.0, 18.0, 35.5, 96.0, 97.0,
|
||||
& 62.0, 40.1, 39.1, 24.3 /)
|
||||
REAL*8 :: WMW(NCOMP) = (/ 23.0, 98.0, 17.0, 63.0, 36.5, 40.1,
|
||||
& 39.1, 24.3 /)
|
||||
REAL*8 :: SMW(NPAIR) = (/ 58.5, 142., 85.0, 132., 80.0, 53.5,
|
||||
& 98.0, 98.0, 115., 63.0, 36.5, 120.,
|
||||
& 247., 136.1, 164., 111., 174.2,
|
||||
& 136.1, 101.1, 74.5, 120.3, 148.3,
|
||||
& 95.2 /)
|
||||
|
||||
COMMON /OTHR/ R, IMW, WMW, SMW
|
||||
! OTHR is read-only
|
||||
|
||||
!=================================================================
|
||||
! Solution/info variables
|
||||
!=================================================================
|
||||
|
||||
CHARACTER(LEN=15) :: SCASE
|
||||
COMMON /CASE/ SCASE
|
||||
!$OMP THREADPRIVATE( /CASE/ )
|
||||
|
||||
REAL*8 :: SULRATW, SULRAT, SODRAT,
|
||||
& SO4RAT, CRNARAT, CRRAT
|
||||
COMMON /CASE2/ SULRATW, SULRAT, SODRAT,
|
||||
& SO4RAT, CRNARAT, CRRAT
|
||||
!$OMP THREADPRIVATE( /CASE2/ )
|
||||
|
||||
REAL*8 :: EPS = 1.D-10
|
||||
COMMON /SOLN/ EPS
|
||||
! SOLN is read-only
|
||||
|
||||
INTEGER :: MAXIT = 100
|
||||
INTEGER :: NSWEEP = 10
|
||||
INTEGER :: NDIV = 5
|
||||
INTEGER :: ICLACT = 0
|
||||
COMMON /SOLN2/ MAXIT, NSWEEP, NDIV
|
||||
! SOLN 2 is read-only
|
||||
|
||||
COMMON /SOLN3/ ICLACT
|
||||
!$OMP THREADPRIVATE( /SOLN3/ )
|
||||
|
||||
!=================================================================
|
||||
! Error system
|
||||
!=================================================================
|
||||
|
||||
CHARACTER(LEN=40) :: ERRMSG(NERRMX) = ' '
|
||||
COMMON /EROR/ ERRMSG
|
||||
!$OMP THREADPRIVATE( /EROR/ )
|
||||
|
||||
INTEGER :: ERRSTK(NERRMX) = 0
|
||||
INTEGER :: NOFER = 0
|
||||
COMMON /EROR2/ ERRSTK, NOFER
|
||||
!$OMP THREADPRIVATE( /EROR2/ )
|
||||
|
||||
LOGICAL :: STKOFL = .FALSE.
|
||||
COMMON /EROR3/ STKOFL
|
||||
!$OMP THREADPRIVATE( /EROR3/ )
|
||||
|
||||
!=================================================================
|
||||
! Generic Variables
|
||||
!=================================================================
|
||||
|
||||
CHARACTER(LEN=15) :: VERSION = '2.0 (03/19/07)'
|
||||
COMMON /CGEN/ VERSION
|
||||
! CGEN is read-only
|
||||
|
||||
REAL*8 :: GREAT = 1.d10
|
||||
REAL*8 :: TINY = 1.d-20
|
||||
REAL*8 :: TINY2 = 1.d-11
|
||||
REAL*8 :: ZERO = 0.d0
|
||||
REAL*8 :: ONE = 1.d0
|
||||
COMMON /CGEN2/ GREAT, TINY, TINY2, ZERO, ONE
|
||||
! CGEN2 is read-only
|
||||
|
||||
!=================================================================
|
||||
! coordinates for debugging
|
||||
!=================================================================
|
||||
INTEGER :: ICOOR, JCOOR, LCOOR
|
||||
COMMON /LOC/ ICOOR, JCOOR, LCOOR
|
||||
!$OMP THREADPRIVATE( /LOC/ )
|
||||
|
||||
!=================================================================
|
||||
! Differentiated Routines
|
||||
!=================================================================
|
||||
|
||||
! changes made by hotp 8/2/07
|
||||
! explicitly declared all variables in SOLUT
|
||||
! made SOLUT THREADPRIVATE for OPENMP parallelization
|
||||
REAL*8 :: CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8
|
||||
REAL*8 :: CHI9, CHI10, CHI11, CHI12, CHI13, CHI14, CHI15
|
||||
REAL*8 :: CHI16, CHI17, PSI1, PSI2, PSI3, PSI4, PSI5, PSI6
|
||||
REAL*8 :: PSI7, PSI8, PSI9, PSI10, PSI11, PSI12, PSI13
|
||||
REAL*8 :: PSI14, PSI15, PSI16, PSI17, A1, A2, A3, A4, A5, A6
|
||||
REAL*8 :: A7, A8, A9, A10, A11, A12, A13, A14, A15, A16, A17
|
||||
COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8,
|
||||
& CHI9, CHI10, CHI11, CHI12, CHI13, CHI14, CHI15,
|
||||
& CHI16, CHI17, PSI1, PSI2, PSI3, PSI4, PSI5, PSI6,
|
||||
& PSI7, PSI8, PSI9, PSI10, PSI11, PSI12, PSI13,
|
||||
& PSI14, PSI15, PSI16, PSI17, A1, A2, A3, A4, A5, A6,
|
||||
& A7, A8, A9, A10, A11, A12, A13, A14, A15, A16, A17
|
||||
!$OMP THREADPRIVATE( /SOLUT/ )
|
||||
|
||||
REAL*8 :: wb(ncomp)
|
||||
COMMON /inpt_b/ wb
|
||||
!$OMP THREADPRIVATE( /inpt_b/ )
|
||||
|
||||
!=================================================================
|
||||
! Case A Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molalab(nions),gamaab(npair),waterab
|
||||
COMMON /ions_ab/ molalab, gamaab, waterab
|
||||
!$OMP THREADPRIVATE( /ions_ab/ )
|
||||
|
||||
REAL*8 :: wab(ncomp)
|
||||
COMMON /inpt_ab/ wab
|
||||
!$OMP THREADPRIVATE( /inpt_ab/ )
|
||||
|
||||
REAL*8 :: gnh3ab
|
||||
COMMON /gas_ab/ gnh3ab
|
||||
!$OMP THREADPRIVATE( /gas_ab/ )
|
||||
|
||||
!=================================================================
|
||||
! Case B Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molalbb(nions), gamabb(npair), waterbb
|
||||
COMMON /ions_bb/ molalbb, gamabb, waterbb
|
||||
!$OMP THREADPRIVATE( /ions_bb/ )
|
||||
|
||||
REAL*8 :: gnh3bb
|
||||
COMMON /gas_bb/ gnh3bb
|
||||
!$OMP THREADPRIVATE( /gas_bb/ )
|
||||
|
||||
!=================================================================
|
||||
! Case C Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molalcb(nions), gamacb(npair), watercb
|
||||
COMMON /ions_cb/ molalcb, gamacb, watercb
|
||||
!$OMP THREADPRIVATE( /ions_cb/ )
|
||||
|
||||
REAL*8 :: gnh3cb
|
||||
COMMON /gas_cb/ gnh3cb
|
||||
!$OMP THREADPRIVATE( /gas_cb/ )
|
||||
|
||||
!=================================================================
|
||||
! Case D Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molaldnrd(nions), gamadnrd(npair), waterdnrd
|
||||
COMMON /ions_dnrd/ molaldnrd, gamadnrd, waterdnrd
|
||||
!$OMP THREADPRIVATE( /ions_dnrd/ )
|
||||
|
||||
REAL*8 :: chi3db, chi4db, psi1db, psi2db
|
||||
COMMON /solut_db/ chi3db, chi4db, psi1db, psi2db
|
||||
!$OMP THREADPRIVATE( /solut_db/ )
|
||||
|
||||
REAL*8 :: molaldnrddb(nions), gamadnrddb(npair), waterdnrddb
|
||||
COMMON /ions_dnrd_db/ molaldnrddb, gamadnrddb,waterdnrddb
|
||||
!$OMP THREADPRIVATE( /ions_dnrd_db/ )
|
||||
|
||||
REAL*8 :: gnh3db, ghno3db
|
||||
COMMON /gas_db/ gnh3db, ghno3db
|
||||
!$OMP THREADPRIVATE( /gas_db/ )
|
||||
|
||||
REAL*8 :: molaldb(nions), molalrdb(npair), gamadb(npair),
|
||||
& waterdb
|
||||
COMMON /ions_db/ molaldb, molalrdb, gamadb, waterdb
|
||||
!$OMP THREADPRIVATE( /ions_db/ )
|
||||
|
||||
!=================================================================
|
||||
! Case E Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molaleb(nions), gamaeb(npair), watereb
|
||||
COMMON /ions_eb/ molaleb, gamaeb, watereb
|
||||
!$OMP THREADPRIVATE( /ions_eb/ )
|
||||
|
||||
REAL*8 :: web(ncomp)
|
||||
COMMON /inpt_eb/ web
|
||||
!$OMP THREADPRIVATE( /inpt_eb/ )
|
||||
|
||||
REAL*8 :: ghno3eb
|
||||
COMMON /gas_eb/ ghno3eb
|
||||
!$OMP THREADPRIVATE( /gas_eb/ )
|
||||
|
||||
!=================================================================
|
||||
! Case F Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molalfb(nions)
|
||||
REAL*8 :: gamafb(npair)
|
||||
REAL*8 :: waterfb
|
||||
COMMON /ions_fb/ molalfb, gamafb, waterfb
|
||||
!$OMP THREADPRIVATE( /ions_fb/ )
|
||||
|
||||
REAL*8 :: wfb(ncomp)
|
||||
COMMON /inpt_fb/ wfb
|
||||
!$OMP THREADPRIVATE( /inpt_fb/ )
|
||||
|
||||
REAL*8 :: ghno3fb
|
||||
COMMON /gas_fb/ ghno3fb
|
||||
!$OMP THREADPRIVATE( /gas_fb/ )
|
||||
|
||||
!=================================================================
|
||||
! Case G Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molalgnrd(nions), gamagnrd(npair), watergnrd
|
||||
COMMON /ions_gnrd/ molalgnrd, gamagnrd, watergnrd
|
||||
!$OMP THREADPRIVATE( /ions_gnrd/ )
|
||||
|
||||
REAL*8 :: molalgnrdgb(nions), gamagnrdgb(npair), watergnrdgb
|
||||
COMMON /ions_gnrd_gb/ molalgnrdgb, gamagnrdgb, watergnrdgb
|
||||
!$OMP THREADPRIVATE( /ions_gnrd_gb/ )
|
||||
|
||||
REAL*8 :: chi4gb, chi5gb, chi6gb, psi2gb
|
||||
COMMON /solut_gb/ chi4gb, chi5gb, chi6gb, psi2gb
|
||||
!$OMP THREADPRIVATE( /solut_gb/ )
|
||||
|
||||
REAL*8 :: gnh3gb, ghno3gb, ghclgb
|
||||
COMMON /gas_gb/ gnh3gb, ghno3gb, ghclgb
|
||||
!$OMP THREADPRIVATE( /gas_gb/ )
|
||||
|
||||
REAL*8 :: molalgb(nions), molalrgb(npair), gamagb(npair),
|
||||
& watergb
|
||||
COMMON /ions_gb/ molalgb, molalrgb, gamagb, watergb
|
||||
!$OMP THREADPRIVATE( /ions_gb/ )
|
||||
|
||||
REAL*8 :: wgb(ncomp)
|
||||
COMMON /inpt_gb/ wgb
|
||||
!$OMP THREADPRIVATE( /inpt_gb/ )
|
||||
|
||||
!=================================================================
|
||||
! Case H Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: molalhnrd(nions), gamahnrd(npair), waterhnrd
|
||||
COMMON /ions_hnrd/ molalhnrd, gamahnrd, waterhnrd
|
||||
!$OMP THREADPRIVATE( /ions_hnrd/ )
|
||||
|
||||
REAL*8 :: molalhnrdhb(nions), gamahnrdhb(npair), waterhnrdhb
|
||||
COMMON /ions_hnrd_hb/ molalhnrdhb, gamahnrdhb, waterhnrdhb
|
||||
!$OMP THREADPRIVATE( /ions_hnrd_hb/ )
|
||||
|
||||
REAL*8 :: chi1hb, chi4hb, chi5hb, chi6hb, chi7hb, chi8hb
|
||||
COMMON /solut_hb/ chi1hb, chi4hb, chi5hb, chi6hb, chi7hb, chi8hb
|
||||
!$OMP THREADPRIVATE( /solut_hb/ )
|
||||
|
||||
REAL*8 :: gnh3hb, ghno3hb, ghclhb
|
||||
COMMON /gas_hb/ gnh3hb, ghno3hb, ghclhb
|
||||
!$OMP THREADPRIVATE( /gas_hb/ )
|
||||
|
||||
REAL*8 :: molalhb(nions), molalrhb(npair), gamahb(npair),
|
||||
& waterhb
|
||||
COMMON /ions_hb/ molalhb, molalrhb, gamahb, waterhb
|
||||
!$OMP THREADPRIVATE( /ions_hb/ )
|
||||
|
||||
!=================================================================
|
||||
! Case I Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: gnh3ib, ghno3ib, ghclib
|
||||
COMMON /gas_ib/ gnh3ib, ghno3ib, ghclib
|
||||
!$OMP THREADPRIVATE( /gas_ib/ )
|
||||
|
||||
REAL*8 :: molalib(nions), gamaib(npair), waterib
|
||||
COMMON /ions_ib/ molalib, gamaib, waterib
|
||||
!$OMP THREADPRIVATE( /ions_ib/ )
|
||||
|
||||
REAL*8 :: wib(ncomp)
|
||||
COMMON /inpt_ib/ wib
|
||||
!$OMP THREADPRIVATE( /inpt_ib/ )
|
||||
|
||||
!=================================================================
|
||||
! Case J Adjoint
|
||||
!=================================================================
|
||||
|
||||
REAL*8 :: gnh3jb, ghno3jb, ghcljb
|
||||
COMMON /gas_jb/ gnh3jb, ghno3jb, ghcljb
|
||||
!$OMP THREADPRIVATE( /gas_jb/ )
|
||||
|
||||
REAL*8 :: molaljb(nions), gamajb(npair), waterjb
|
||||
COMMON /ions_jb/ molaljb, gamajb, waterjb
|
||||
!$OMP THREADPRIVATE( /ions_jb/ )
|
||||
|
||||
REAL*8 :: wjb(ncomp)
|
||||
COMMON /inpt_jb/ wjb
|
||||
!$OMP THREADPRIVATE( /inpt_jb/ )
|
||||
|
||||
!
|
||||
! === END OF INCLUDE FILE ==============================================
|
||||
!
|
||||
38
code/new/linoz.com
Normal file
38
code/new/linoz.com
Normal file
@ -0,0 +1,38 @@
|
||||
C $Id: linoz.com,v 1.1 2009/06/09 21:51:54 daven Exp $
|
||||
C $Log: linoz.com,v $
|
||||
C Revision 1.1 2009/06/09 21:51:54 daven
|
||||
C Initial revision
|
||||
C
|
||||
C Revision 2.23 2000/05/24 23:09:33 pjc
|
||||
C Changed criteria for using Linoz: now must have [Ox]>150ppb AND Level>=9.
|
||||
C
|
||||
C Revision 2.10 2000/03/23 20:39:04 pjc
|
||||
C Initial version created out of McLinden's original files.
|
||||
C
|
||||
|
||||
C common block for linoz. Created by Philip Cameron-Smith, 00/1/14.
|
||||
|
||||
INTEGER nfields_linoz,nlevels_linoz,nlat_linoz,nmonths_linoz
|
||||
PARAMETER(nfields_linoz=7) ! Number of linoz fields.
|
||||
PARAMETER(nlevels_linoz=25) ! Number of levels in linoz fields.
|
||||
PARAMETER(nlat_linoz=18) ! Number of latitudes in linoz fields.
|
||||
PARAMETER(nmonths_linoz=12) !Number of months in linoz fields.
|
||||
|
||||
REAL*8 TPARM(nlevels_linoz,nlat_linoz,nmonths_linoz,nfields_linoz)
|
||||
REAL*8 TLSTT(JJPAR,LLPAR,nfields_linoz)
|
||||
COMMON/linoz_fields/TPARM,TLSTT
|
||||
|
||||
REAL*8 linoz_min_alt !Minimum altitude covered by linoz data.
|
||||
PARAMETER(linoz_min_alt=10) ! units=[km]
|
||||
INTEGER linoz_min_lev ! Minimum GCM level linoz can cover.
|
||||
COMMON/linoz_levels/linoz_min_lev
|
||||
|
||||
C*PJC* Need to define the minimum Level at which Linoz can be used.
|
||||
C NB: Linoz data goes down to ~277mbar, so any part of a layer below
|
||||
C this has effectively no Linoz chemistry.
|
||||
INTEGER Linoz_min_L
|
||||
PARAMETER(Linoz_min_L=9)
|
||||
C*PJC* Define ozone tropopause, below which Linoz not used.
|
||||
REAL*8 Linoz_min_Ox
|
||||
PARAMETER(Linoz_min_Ox=150E-9) ! VMR, so 150E-9 = 150 ppb.
|
||||
|
||||
1434
code/new/linoz_mod.f
Normal file
1434
code/new/linoz_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
218
code/new/linpack.f
Normal file
218
code/new/linpack.f
Normal file
@ -0,0 +1,218 @@
|
||||
c
|
||||
c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License”
|
||||
c or “3-clause license”)
|
||||
c Please read attached file License.txt
|
||||
c
|
||||
subroutine dpofa(a,lda,n,info)
|
||||
integer lda,n,info
|
||||
double precision a(lda,*)
|
||||
c
|
||||
c dpofa factors a double precision symmetric positive definite
|
||||
c matrix.
|
||||
c
|
||||
c dpofa is usually called by dpoco, but it can be called
|
||||
c directly with a saving in time if rcond is not needed.
|
||||
c (time for dpoco) = (1 + 18/n)*(time for dpofa) .
|
||||
c
|
||||
c on entry
|
||||
c
|
||||
c a double precision(lda, n)
|
||||
c the symmetric matrix to be factored. only the
|
||||
c diagonal and upper triangle are used.
|
||||
c
|
||||
c lda integer
|
||||
c the leading dimension of the array a .
|
||||
c
|
||||
c n integer
|
||||
c the order of the matrix a .
|
||||
c
|
||||
c on return
|
||||
c
|
||||
c a an upper triangular matrix r so that a = trans(r)*r
|
||||
c where trans(r) is the transpose.
|
||||
c the strict lower triangle is unaltered.
|
||||
c if info .ne. 0 , the factorization is not complete.
|
||||
c
|
||||
c info integer
|
||||
c = 0 for normal return.
|
||||
c = k signals an error condition. the leading minor
|
||||
c of order k is not positive definite.
|
||||
c
|
||||
c linpack. this version dated 08/14/78 .
|
||||
c cleve moler, university of new mexico, argonne national lab.
|
||||
c
|
||||
c subroutines and functions
|
||||
c
|
||||
c blas ddot
|
||||
c fortran sqrt
|
||||
c
|
||||
c internal variables
|
||||
c
|
||||
double precision ddot,t
|
||||
double precision s
|
||||
integer j,jm1,k
|
||||
c begin block with ...exits to 40
|
||||
c
|
||||
c
|
||||
do 30 j = 1, n
|
||||
info = j
|
||||
s = 0.0d0
|
||||
jm1 = j - 1
|
||||
if (jm1 .lt. 1) go to 20
|
||||
do 10 k = 1, jm1
|
||||
t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1)
|
||||
t = t/a(k,k)
|
||||
a(k,j) = t
|
||||
s = s + t*t
|
||||
10 continue
|
||||
20 continue
|
||||
s = a(j,j) - s
|
||||
c ......exit
|
||||
if (s .le. 0.0d0) go to 40
|
||||
a(j,j) = sqrt(s)
|
||||
30 continue
|
||||
info = 0
|
||||
40 continue
|
||||
return
|
||||
end
|
||||
|
||||
c====================== The end of dpofa ===============================
|
||||
|
||||
subroutine dtrsl(t,ldt,n,b,job,info)
|
||||
integer ldt,n,job,info
|
||||
double precision t(ldt,*),b(*)
|
||||
c
|
||||
c
|
||||
c dtrsl solves systems of the form
|
||||
c
|
||||
c t * x = b
|
||||
c or
|
||||
c trans(t) * x = b
|
||||
c
|
||||
c where t is a triangular matrix of order n. here trans(t)
|
||||
c denotes the transpose of the matrix t.
|
||||
c
|
||||
c on entry
|
||||
c
|
||||
c t double precision(ldt,n)
|
||||
c t contains the matrix of the system. the zero
|
||||
c elements of the matrix are not referenced, and
|
||||
c the corresponding elements of the array can be
|
||||
c used to store other information.
|
||||
c
|
||||
c ldt integer
|
||||
c ldt is the leading dimension of the array t.
|
||||
c
|
||||
c n integer
|
||||
c n is the order of the system.
|
||||
c
|
||||
c b double precision(n).
|
||||
c b contains the right hand side of the system.
|
||||
c
|
||||
c job integer
|
||||
c job specifies what kind of system is to be solved.
|
||||
c if job is
|
||||
c
|
||||
c 00 solve t*x=b, t lower triangular,
|
||||
c 01 solve t*x=b, t upper triangular,
|
||||
c 10 solve trans(t)*x=b, t lower triangular,
|
||||
c 11 solve trans(t)*x=b, t upper triangular.
|
||||
c
|
||||
c on return
|
||||
c
|
||||
c b b contains the solution, if info .eq. 0.
|
||||
c otherwise b is unaltered.
|
||||
c
|
||||
c info integer
|
||||
c info contains zero if the system is nonsingular.
|
||||
c otherwise info contains the index of
|
||||
c the first zero diagonal element of t.
|
||||
c
|
||||
c linpack. this version dated 08/14/78 .
|
||||
c g. w. stewart, university of maryland, argonne national lab.
|
||||
c
|
||||
c subroutines and functions
|
||||
c
|
||||
c blas daxpy,ddot
|
||||
c fortran mod
|
||||
c
|
||||
c internal variables
|
||||
c
|
||||
double precision ddot,temp
|
||||
integer case,j,jj
|
||||
c
|
||||
c begin block permitting ...exits to 150
|
||||
c
|
||||
c check for zero diagonal elements.
|
||||
c
|
||||
do 10 info = 1, n
|
||||
c ......exit
|
||||
if (t(info,info) .eq. 0.0d0) go to 150
|
||||
10 continue
|
||||
info = 0
|
||||
c
|
||||
c determine the task and go to it.
|
||||
c
|
||||
case = 1
|
||||
if (mod(job,10) .ne. 0) case = 2
|
||||
if (mod(job,100)/10 .ne. 0) case = case + 2
|
||||
go to (20,50,80,110), case
|
||||
c
|
||||
c solve t*x=b for t lower triangular
|
||||
c
|
||||
20 continue
|
||||
b(1) = b(1)/t(1,1)
|
||||
if (n .lt. 2) go to 40
|
||||
do 30 j = 2, n
|
||||
temp = -b(j-1)
|
||||
call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1)
|
||||
b(j) = b(j)/t(j,j)
|
||||
30 continue
|
||||
40 continue
|
||||
go to 140
|
||||
c
|
||||
c solve t*x=b for t upper triangular.
|
||||
c
|
||||
50 continue
|
||||
b(n) = b(n)/t(n,n)
|
||||
if (n .lt. 2) go to 70
|
||||
do 60 jj = 2, n
|
||||
j = n - jj + 1
|
||||
temp = -b(j+1)
|
||||
call daxpy(j,temp,t(1,j+1),1,b(1),1)
|
||||
b(j) = b(j)/t(j,j)
|
||||
60 continue
|
||||
70 continue
|
||||
go to 140
|
||||
c
|
||||
c solve trans(t)*x=b for t lower triangular.
|
||||
c
|
||||
80 continue
|
||||
b(n) = b(n)/t(n,n)
|
||||
if (n .lt. 2) go to 100
|
||||
do 90 jj = 2, n
|
||||
j = n - jj + 1
|
||||
b(j) = b(j) - ddot(jj-1,t(j+1,j),1,b(j+1),1)
|
||||
b(j) = b(j)/t(j,j)
|
||||
90 continue
|
||||
100 continue
|
||||
go to 140
|
||||
c
|
||||
c solve trans(t)*x=b for t upper triangular.
|
||||
c
|
||||
110 continue
|
||||
b(1) = b(1)/t(1,1)
|
||||
if (n .lt. 2) go to 130
|
||||
do 120 j = 2, n
|
||||
b(j) = b(j) - ddot(j-1,t(1,j),1,b(1),1)
|
||||
b(j) = b(j)/t(j,j)
|
||||
120 continue
|
||||
130 continue
|
||||
140 continue
|
||||
150 continue
|
||||
return
|
||||
end
|
||||
|
||||
c====================== The end of dtrsl ===============================
|
||||
|
||||
|
||||
1102
code/new/netcdf_util_mod.f
Normal file
1102
code/new/netcdf_util_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
3955
code/new/routines.f
Normal file
3955
code/new/routines.f
Normal file
File diff suppressed because it is too large
Load Diff
1224
code/new/strat_chem_mod.f
Normal file
1224
code/new/strat_chem_mod.f
Normal file
File diff suppressed because it is too large
Load Diff
32
code/new/timer.f
Normal file
32
code/new/timer.f
Normal file
@ -0,0 +1,32 @@
|
||||
c
|
||||
c L-BFGS-B is released under the “New BSD License” (aka “Modified BSD License”
|
||||
c or “3-clause license”)
|
||||
c Please read attached file License.txt
|
||||
c
|
||||
subroutine timer(ttime)
|
||||
double precision ttime
|
||||
c
|
||||
real temp
|
||||
c
|
||||
c This routine computes cpu time in double precision; it makes use of
|
||||
c the intrinsic f90 cpu_time therefore a conversion type is
|
||||
c needed.
|
||||
c
|
||||
c J.L Morales Departamento de Matematicas,
|
||||
c Instituto Tecnologico Autonomo de Mexico
|
||||
c Mexico D.F.
|
||||
c
|
||||
c J.L Nocedal Department of Electrical Engineering and
|
||||
c Computer Science.
|
||||
c Northwestern University. Evanston, IL. USA
|
||||
c
|
||||
c January 21, 2011
|
||||
c
|
||||
temp = sngl(ttime)
|
||||
call cpu_time(temp)
|
||||
ttime = dble(temp)
|
||||
|
||||
return
|
||||
|
||||
end
|
||||
|
||||
Reference in New Issue
Block a user