Changeset 7448


Ignore:
Timestamp:
06/01/18 14:32:59 (3 weeks ago)
Author:
baker
Message:

use Fortran 2003 libray_wrapper.f90 to call Fortran Subroutine LIBRAY from C

Location:
trunk/src/seismic_processing/rayloc_ew
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/src/seismic_processing/rayloc_ew/librayloc1.f

    r3334 r7448  
    1       subroutine libray(tokenName, dir_in) 
     1      Subroutine LIBRAY( tokenName, dir_in ) 
    22c 
    33c   The main program gets the command line argument and opens input, 
     
    1010      include 'hypocm.inc' 
    1111c 
     12      Character, Intent ( IN ) :: tokenName*(*) 
     13      Character, Intent ( IN ) :: dir_in*(*) 
     14c 
     15      Integer tok_len 
     16      Integer dir_len 
    1217c 
    1318      character*8 phlst(2) 
     
    1520      logical*4 prnt(3) 
    1621c 
    17       integer*4 ntrbl,nphase,nexit 
     22      integer*4 nphase,nexit 
    1823c      integer*4 iargc,nargs 
    1924      integer*4 min,mout,merr 
     
    3439c IGD 06/01/04 Increased static array to allow for pathname 
    3540      character*20 modnam 
    36       character*1001 dir_in 
    37       character*1001 tokenName 
    3841      character*1001 dirname 
    39       character*1001 modelName  
    4042 
    4143      common /my_dir/dirname 
     
    7476      roff=.58984375+(rchi-.375) 
    7577 
    76       dirname=dir_in 
     78      tok_len = LEN_TRIM( tokenName ) 
     79      dirname = dir_in 
     80      dir_len = LEN_TRIM( dirname ) 
    7781c 
    7882c 
    7983c Initialize the reference earth model 
    8084c 
    81       modelname=dirname(1:ntrbl(dirname))//'/'//modnam 
    82        
    8385      call freeunit(mlu) 
    84       call tabin(mlu,modelname) 
     86      call tabin(mlu,dirname(1:dir_len)//'/'//modnam) 
    8587      call brnset(1,phlst,prnt) 
    8688c 
    8789      call freeunit(merr) 
    88       open(merr,file=dirname(1:ntrbl(dirname))//'/'// 
    89      1    'RayLocError'//tokenName(1:ntrbl(tokenName))//'.txt', 
     90      open(merr,file=dirname(1:dir_len)//'/'// 
     91     1    'RayLocError'//tokenName(1:tok_len)//'.txt', 
    9092     2    access='sequential',form='formatted',status='new') 
    9193c 
     
    9395c 
    9496      call freeunit(min) 
    95       open(min,file=dirname(1:ntrbl(dirname))//'/'// 
    96      1     'RayLocInput'//tokenName(1:ntrbl(tokenName))//'.txt', 
     97      open(min,file=dirname(1:dir_len)//'/'// 
     98     1     'RayLocInput'//tokenName(1:tok_len)//'.txt', 
    9799     2     access='sequential',form='formatted',status='old') 
    98100      rewind(min) 
     
    109111c 
    110112      call freeunit(mout) 
    111       open(mout,file=dirname(1:ntrbl(dirname))//'/'// 
    112      1     'RayLocOutput'//tokenName(1:ntrbl(tokenName))//'.txt', 
     113      open(mout,file=dirname(1:dir_len)//'/'// 
     114     1     'RayLocOutput'//tokenName(1:tok_len)//'.txt', 
    113115     2     access='sequential',form='formatted',status='new') 
    114116      call output(nphase) 
  • trunk/src/seismic_processing/rayloc_ew/makefile.nt

    r7444 r7448  
    2323        hypo.f \ 
    2424        output.f 
    25 F_STUB = librayloc1.f 
     25F_STUB = \ 
     26        libray_wrapper.f90 \ 
     27        librayloc1.f 
    2628LIBS = \ 
    2729        $L\rayloc_message_rw.obj \ 
     
    5961                /link $(SPECIFIC_FLAGS) /out:$B\rayloc_ew.exe 
    6062 
    61 # 
    62 # rayloc1.c calls Fortran subroutine libray( tokenName, dir_in ) in 
    63 # librayloc1.f using the function prototype: 
    64 # 
    65 #    extern void libray_( const char *, const char *, size_t, size_t ); 
    66 # 
    67 # Linux:   libray_      gfortran appends underscore, 
    68 #                       converts Fortran SUBROUTINE name to lower case 
    69 # 
    70 # No change needed for gfortran on Linux 
    71 # 
    72 # Windows: LIBRAY       ifort does not append underscore, 
    73 #                       converts Fortran SUBROUTINE name to upper case 
    74 # 
    75 # For ifort on Windows, /Dlibray_=LIBRAY 
    76 # 
    77  
    78 !IF "$(FC)" == "ifort" 
    79 EXTERN_LIBRAY = /Dlibray_=LIBRAY 
    80 !ELSE 
    81 EXTERN_LIBRAY = 
    82 !ENDIF 
    83 rayloc1.obj:   rayloc1.c 
    84         $(CC) $(GLOBALFLAGS) /nologo /DUSE_LOGIT $(EXTERN_LIBRAY) \ 
    85               $(cflags) $(cdebug) $(cvarsmt) $(tflags) rayloc1.c 
    86  
    8763rayloc_test1: $(F_MAIN) $(F_SRCS) 
    8864        $(FC) $(FFLAGS) $(F_MAIN) $(F_SRCS) /Fe$B\rayloc_test1.exe 
  • trunk/src/seismic_processing/rayloc_ew/makefile.unix

    r7441 r7448  
    2626        hypo.f \ 
    2727        output.f 
    28 F_STUB = librayloc1.f 
     28F_STUB = \ 
     29        libray_wrapper.f90 \ 
     30        librayloc1.f 
    2931LIBS = \ 
    3032        $L/rayloc_message_rw.o \ 
     
    5759                -o $B/rayloc_ew 
    5860 
    59 # 
    60 # rayloc1.c calls Fortran subroutine libray( tokenName, dir_in ) in 
    61 # librayloc1.f using the function prototype: 
    62 # 
    63 #    extern void libray_( const char *, const char *, size_t, size_t ); 
    64 # 
    65 # Linux:   libray_      gfortran appends underscore, 
    66 #                       converts Fortran SUBROUTINE name to lower case 
    67 # 
    68 # No change needed for gfortran on Linux 
    69 # 
    70 # Windows: LIBRAY       ifort does not append underscore, 
    71 #                       converts Fortran SUBROUTINE name to upper case 
    72 # 
    73 # For ifort on Windows, /Dlibray_=LIBRAY 
    74 # 
    75  
    76 EXTERN_LIBRAY = 
    77 rayloc1.o:   rayloc1.c 
    78         $(CC) -c $(CFLAGS) $(CPPFLAGS) $(EXTERN_LIBRAY) rayloc1.c 
    79  
    8061rayloc_test1:         $(F_MAIN) $(F_SRCS) 
    8162        $(FC) $(FFLAGS) $(F_MAIN) $(F_SRCS) -o rayloc_test1 
  • trunk/src/seismic_processing/rayloc_ew/rayloc1.c

    r7319 r7448  
    5252    copyright            : (C) 2004 by Ilya Dricker, ISTI 
    5353    email                : i.dricker@isti.com 
    54  ***************************************************************************/ 
    55  
    56 /*************************************************************************** 
    57  *                                                                         * 
    58  * rayloc1.c calls Fortran subroutine libray( tokenName, dir_in ) in       * 
    59  * librayloc1.f using the function prototype:                              * 
    60  *                                                                         * 
    61  *    extern void libray_( const char *, const char *, size_t, size_t );   * 
    62  *                                                                         * 
    63  * Linux:   libray_     gfortran appends underscore,                       * 
    64  *                      converts Fortran SUBROUTINE name to lower case     * 
    65  *                                                                         * 
    66  * No change needed for gfortran on Linux                                  * 
    67  *                                                                         * 
    68  * Windows: LIBRAY      ifort does not append underscore,                  * 
    69  *                      converts Fortran SUBROUTINE name to upper case     * 
    70  *                                                                         * 
    71  * For ifort on Windows, /Dlibray_=LIBRAY                                  * 
    72  *                                                                         * 
    7354 ***************************************************************************/ 
    7455 
     
    10081 
    10182 
    102 int 
     83static int 
    10384        rayloc_print_single_phase(FILE *fd, 
    10485                       RAYLOC_PHASES *unused_list, 
    10586                       GLOBAL_PHSLINE_STRUCT *phase, 
    10687                       RAYLOC_STATIONS *stns); 
    107 int 
     88static int 
    10889        rayloc_print_phases(FILE *fd, 
    10990                      RAYLOC_PHASES *unused_list, 
     
    11192                      RAYLOC_STATIONS *stns); 
    11293 
    113 int 
     94static int 
    11495        rayloc_maintain_token_files(const char *token, const char *dirName); 
    11596 
    11697 
    117 int 
     98static int 
    11899        rayloc_msg_to_rayloc_input(GLOBAL_LOC_STRUCT *p_loc, 
    119100                               RAYLOC_PHASES *unused_list, 
     
    122103                               RAYLOC_STATIONS *sta); 
    123104 
    124 void 
     105static void 
    125106        rayloc_print_flags(FILE *fd, RAYLOC_PROC_FLAGS *flags); 
    126107 
     
    129110        lib_rayloc_stub(const char *token, const char *dirname) 
    130111        { 
    131                         extern void libray_( const char *, const char *, size_t, size_t ); 
    132                         char token1[1001]; 
    133                         char dirname1[1001]; 
    134                         char tmpFile[1001]; 
    135                         int retVal; 
    136                         struct stat buf; 
    137  
    138  
    139                         /* Maintainance portion of the code */ 
    140  
    141                         /* Check if provided directory is really a writable dir */ 
    142                         retVal = stat(dirname, &buf); 
    143                         if (-1 == retVal) 
    144                                 return RAYLOC_NOT_DIRECTORY; 
    145                         if (!(buf.st_mode & S_IFDIR)) /* Must be directory */ 
    146                                 return RAYLOC_NOT_DIRECTORY; 
    147                         if (!(buf.st_mode & S_IWUSR)) /* Must be writable by user */ 
    148                                 return RAYLOC_DIR_NOT_WRITABLE; 
    149  
    150                         /* Check if model files exist */ 
    151                         sprintf(tmpFile, "%s/%s", dirname, MODEL_HEAD); 
    152                         retVal = stat(tmpFile, &buf); 
    153                         if (-1 == retVal) 
    154                                 return RAYLOC_MODEL_HEAD_NOT_EXIST; 
    155                         if (!(buf.st_mode & S_IFREG)) /* Must be regular file */ 
    156                                 return RAYLOC_MODEL_HEAD_NOT_EXIST; 
    157  
    158                         sprintf(tmpFile, "%s/%s", dirname, MODEL_TABLE); 
    159                         retVal = stat(tmpFile, &buf); 
    160                         if (-1 == retVal) 
    161                                 return RAYLOC_MODEL_TABLE_NOT_EXIST; 
    162                         if (!(buf.st_mode & S_IFREG)) /* Must be regular file */ 
    163                                 return RAYLOC_MODEL_TABLE_NOT_EXIST; 
    164  
    165                         sprintf(tmpFile, "%s/%s", dirname, TAU_TABLE); 
    166                         retVal = stat(tmpFile, &buf); 
    167                         if (-1 == retVal) 
    168                                 return RAYLOC_TAU_TABLE_NOT_EXIST; 
    169                         if (!(buf.st_mode & S_IFREG)) /* Must be regular file */ 
    170                                 return RAYLOC_TAU_TABLE_NOT_EXIST; 
    171  
    172                         retVal = rayloc_maintain_token_files(token, dirname); 
    173  
    174                         memset(token1, ' ', sizeof(token1)); 
    175                         memset(dirname1, ' ', sizeof(dirname1)); 
    176                         strncpy(token1, token, strlen(token)); 
    177                         strncpy(dirname1, dirname, strlen(dirname)); 
    178  
    179                         libray_ (token1, dirname1, strlen(token1), strlen(dirname1)); 
    180                         return RAYLOC_SUCCESS; 
    181         } 
    182  
    183 int 
     112                extern void libray_wrapper( const char *, const char * ); 
     113                char tmpFile[1001]; 
     114                int retVal; 
     115                struct stat buf; 
     116 
     117 
     118                /* Maintenance portion of the code */ 
     119 
     120                /* Check if provided directory is really a writable dir */ 
     121                retVal = stat(dirname, &buf); 
     122                if (-1 == retVal) 
     123                        return RAYLOC_NOT_DIRECTORY; 
     124                if (!(buf.st_mode & S_IFDIR)) /* Must be directory */ 
     125                        return RAYLOC_NOT_DIRECTORY; 
     126                if (!(buf.st_mode & S_IWUSR)) /* Must be writable by user */ 
     127                        return RAYLOC_DIR_NOT_WRITABLE; 
     128 
     129                /* Check if model files exist */ 
     130                sprintf(tmpFile, "%s/%s", dirname, MODEL_HEAD); 
     131                retVal = stat(tmpFile, &buf); 
     132                if (-1 == retVal) 
     133                        return RAYLOC_MODEL_HEAD_NOT_EXIST; 
     134                if (!(buf.st_mode & S_IFREG)) /* Must be regular file */ 
     135                        return RAYLOC_MODEL_HEAD_NOT_EXIST; 
     136 
     137                sprintf(tmpFile, "%s/%s", dirname, MODEL_TABLE); 
     138                retVal = stat(tmpFile, &buf); 
     139                if (-1 == retVal) 
     140                        return RAYLOC_MODEL_TABLE_NOT_EXIST; 
     141                if (!(buf.st_mode & S_IFREG)) /* Must be regular file */ 
     142                        return RAYLOC_MODEL_TABLE_NOT_EXIST; 
     143 
     144                sprintf(tmpFile, "%s/%s", dirname, TAU_TABLE); 
     145                retVal = stat(tmpFile, &buf); 
     146                if (-1 == retVal) 
     147                        return RAYLOC_TAU_TABLE_NOT_EXIST; 
     148                if (!(buf.st_mode & S_IFREG)) /* Must be regular file */ 
     149                        return RAYLOC_TAU_TABLE_NOT_EXIST; 
     150 
     151                retVal = rayloc_maintain_token_files(token, dirname); 
     152 
     153                libray_wrapper( token, dirname ); 
     154 
     155                return RAYLOC_SUCCESS; 
     156        } 
     157 
     158static int 
    184159        rayloc_maintain_token_files(const char *token, const char *dirName) 
    185160        { 
     
    390365        } 
    391366 
    392  
    393 int 
     367static int 
    394368        rayloc_msg_to_rayloc_input(GLOBAL_LOC_STRUCT *p_loc, 
    395369                                  RAYLOC_PHASES *unused_list, 
     
    436410        } 
    437411 
    438 void 
     412static void 
    439413        rayloc_print_flags(FILE *fd, RAYLOC_PROC_FLAGS *flags) 
    440414        { 
     
    504478} 
    505479 
    506 int 
     480static int 
    507481        rayloc_print_phases(FILE *fd, 
    508482                     RAYLOC_PHASES *unused_list, 
     
    525499        } 
    526500 
    527 int 
     501static int 
    528502        rayloc_print_single_phase(FILE *fd, 
    529503                   RAYLOC_PHASES *unused_list, 
Note: See TracChangeset for help on using the changeset viewer.