text:
c     Subroutine to process qff files
c     AJ_Kettle, 19Nov2019
c     20200607: modified width source_id field from 4 to 8
c     20200609: modified width source_id field from 16 to 32
c     20210216: modified to handle different qff format
c     20210724: export list of stations not found from wish list

      SUBROUTINE process_qff_files20210724(
     +  s_date_st,s_time_st,s_zone_st,i_values_st,
     +  s_directory_output_header,s_directory_output_observation,
     +  s_directory_output_lite,s_directory_output_receipt,
     +  s_directory_output_lastfile,s_directory_output_diagnostics,
     +  s_directory_output_diagnostics_segfault,
     +  s_directory_output_diagnostics_notthere,
     +  s_directory_output_qc,s_directory_output_receipt_linecount,
     +  s_directory_file_source,
     +  s_directory_temp,
     +  l_rgh_files,l_files,s_vec_files,
     +  f_ndflag,
     +  l_scoutput_rgh,l_scoutput,ilen,
     +  s_scoutput_stnconfig_lines,
     +  s_scoutput_header,s_scoutput_searchname,
     +  s_qckey_timescale_spec,l_qckey,
     +  s_qckey_sourceflag,s_qckey_c3sflag,s_qckey_timescale)

      IMPLICIT NONE
c************************************************************************
c     Variables passed into subroutine

      CHARACTER(LEN=8)    :: s_date_st
      CHARACTER(LEN=10)   :: s_time_st
      CHARACTER(LEN=5)    :: s_zone_st
      INTEGER             :: i_values_st(8)

      CHARACTER(LEN=300)  :: s_directory_output_header
      CHARACTER(LEN=300)  :: s_directory_output_observation
      CHARACTER(LEN=300)  :: s_directory_output_lite
      CHARACTER(LEN=300)  :: s_directory_output_receipt
      CHARACTER(LEN=300)  :: s_directory_output_lastfile
      CHARACTER(LEN=300)  :: s_directory_output_diagnostics
      CHARACTER(LEN=300)  :: s_directory_output_diagnostics_segfault
      CHARACTER(LEN=300)  :: s_directory_output_diagnostics_notthere
      CHARACTER(LEN=300)  :: s_directory_output_qc
      CHARACTER(LEN=300)  :: s_directory_output_receipt_linecount

      CHARACTER(LEN=300)  :: s_directory_file_source

      CHARACTER(LEN=300)  :: s_directory_temp

      INTEGER             :: l_rgh_files
      INTEGER             :: l_files
      CHARACTER(LEN=300)  :: s_vec_files(l_rgh_files)

      REAL                :: f_ndflag

c     info new qc table
      CHARACTER(LEN=300)  :: s_qckey_timescale_spec
      INTEGER             :: l_qckey
      CHARACTER(LEN=2)    :: s_qckey_sourceflag(100)
      CHARACTER(LEN=2)    :: s_qckey_c3sflag(100)
      CHARACTER(LEN=300)  :: s_qckey_timescale(100)
c*****
c     Stnconfig information
      INTEGER             :: l_scoutput_rgh
      INTEGER             :: l_scoutput
c      INTEGER             :: l_scoutput_numfield
      INTEGER             :: ilen

      CHARACTER(LEN=*)    :: s_scoutput_header
      CHARACTER(LEN=*)    :: s_scoutput_stnconfig_lines(l_scoutput_rgh)
      CHARACTER(LEN=*)    :: s_scoutput_searchname(l_scoutput_rgh)   !16
c*****
c     Variables originally from stnconfig-read
      INTEGER,PARAMETER   :: l_cc_rgh=100     !record nrs expected for stn
      INTEGER             :: l_collect_cnt

      CHARACTER(LEN=ilen) :: s_collect_primary_id(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_record_number(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_secondary_id(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_station_name(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_longitude(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_latitude(l_cc_rgh)
      CHARACTER(LEN=ilen) ::
     +     s_collect_height_station_above_sea_level(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_data_policy_licence(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_source_id(l_cc_rgh)

c     Variables originally from stnconfig-write
      CHARACTER(LEN=ilen) :: s_collect_region(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_operating_territory(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_station_type(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_platform_type(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_platform_sub_type(l_cc_rgh)
      CHARACTER(LEN=ilen)::s_collect_primary_station_id_scheme(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_location_accuracy(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_location_method(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_location_quality(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_station_crs(l_cc_rgh)
      CHARACTER(LEN=ilen) ::
     +    s_collect_height_station_above_local_ground(l_cc_rgh)
      CHARACTER(LEN=ilen) ::
     +    s_collect_height_station_above_sea_level_acc(l_cc_rgh)
      CHARACTER(LEN=ilen) :: s_collect_sea_level_datum(l_cc_rgh)

c     Archives up to 50 column & 20 lines from stnconfig-write file
      CHARACTER(LEN=ilen) :: s_collect_datalines(l_cc_rgh,50)
      CHARACTER(LEN=ilen) :: s_collect_vec_header(50)
      INTEGER             :: l_collect_numfield

      INTEGER             :: l_collect_distinct
      CHARACTER(LEN=1)    :: s_collect_flagambig(l_cc_rgh)
c*****
c*****
c*****
c     Variables used in subroutine

      INTEGER             :: i,j,k,ii,jj,kk
      CHARACTER(LEN=300)  :: s_file_single
      CHARACTER(LEN=300)  :: s_stnname_isolated
      CHARACTER(LEN=300)  :: s_stnlook

c     28Oct2020: trial failed with 2 000 000 line allocation
      INTEGER,PARAMETER   :: l_rgh=1300000 !1200000 !1000000
      INTEGER             :: l_lines

      INTEGER             :: i_start

c     master variable declarations here
      CHARACTER(LEN=16)   :: s_vec_station_id(l_rgh)
      CHARACTER(LEN=64)   :: s_vec_station_name(l_rgh)
      CHARACTER(LEN=4)    :: s_vec_year(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_month(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_day(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_hour(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_minute(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_latitude(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_longitude(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_elevation(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_airt_c(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_airt_source_id(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_airt_qc_flag(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_dewp_c(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_dewp_source_id(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_dewp_qc_flag(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_stnp_hpa(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_stnp_source_id(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_stnp_qc_flag(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_slpr_hpa(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_slpr_source_id(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_slpr_qc_flag(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_wdir_deg(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_wdir_source_id(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_wdir_qc_flag(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_wspd_ms(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_wspd_source_id(l_rgh)
      CHARACTER(LEN=8)    :: s_vec_wspd_qc_flag(l_rgh)
c*****
c     Variables to assess original precision
      CHARACTER(LEN=32)   :: s_vec_airt_origprec_c(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_dewp_origprec_c(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_stnp_origprec_hpa(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_slpr_origprec_hpa(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_wdir_origprec_deg(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_wspd_origprec_ms(l_rgh)

      CHARACTER(LEN=32)   :: s_vec_airt_origprec_empir_c(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_dewp_origprec_empir_c(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_stnp_origprec_empir_hpa(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_slpr_origprec_empir_hpa(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_wdir_origprec_empir_deg(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_wspd_origprec_empir_ms(l_rgh)

      CHARACTER(LEN=1)    :: s_vec_airt_origprec_neglog(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_dewp_origprec_neglog(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_stnp_origprec_neglog(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_slpr_origprec_neglog(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_wdir_origprec_neglog(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_wspd_origprec_neglog(l_rgh)
c*****
c     Float conversions of all variables
      REAL                :: f_vec_airt_c(l_rgh)
      REAL                :: f_vec_dewp_c(l_rgh)
      REAL                :: f_vec_stnp_hpa(l_rgh)
      REAL                :: f_vec_slpr_hpa(l_rgh)
      REAL                :: f_vec_wdir_deg(l_rgh)
      REAL                :: f_vec_wspd_ms(l_rgh)
c*****
c     Unit conversions of variables
      REAL                :: f_vec_airt_k(l_rgh)
      REAL                :: f_vec_dewp_k(l_rgh)
      REAL                :: f_vec_stnp_pa(l_rgh)
      REAL                :: f_vec_slpr_pa(l_rgh)

      CHARACTER(LEN=32)   :: s_vec_airt_k(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_dewp_k(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_stnp_pa(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_slpr_pa(l_rgh)

      CHARACTER(LEN=32)   :: s_vec_airt_convprec_empir_k(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_dewp_convprec_empir_k(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_stnp_convprec_empir_pa(l_rgh)
      CHARACTER(LEN=32)   :: s_vec_slpr_convprec_empir_pa(l_rgh)
c*****
c     Record number from stnconfig file matching
      CHARACTER(LEN=2)    :: s_vec_airt_recordnum(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_dewp_recordnum(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_stnp_recordnum(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_slpr_recordnum(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_wdir_recordnum(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_wspd_recordnum(l_rgh)
c*****
c     CDM qc flag
      CHARACTER(LEN=1)    :: s_vec_airt_cdmqc(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_dewp_cdmqc(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_stnp_cdmqc(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_slpr_cdmqc(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_wdir_cdmqc(l_rgh)
      CHARACTER(LEN=1)    :: s_vec_wspd_cdmqc(l_rgh)

      CHARACTER(LEN=2)    :: s_vec_airt_cdmqcmethod(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_dewp_cdmqcmethod(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_stnp_cdmqcmethod(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_slpr_cdmqcmethod(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_wdir_cdmqcmethod(l_rgh)
      CHARACTER(LEN=2)    :: s_vec_wspd_cdmqcmethod(l_rgh)
c*****
      INTEGER             :: i_flag

      INTEGER             :: i_bad_test1_nostnlist
      INTEGER             :: i_bad_test2_floatconvert
      INTEGER             :: i_bad_test3_sourceid_prob
      INTEGER             :: i_bad_test4_segfault
c*****
c     Hardwired codes for CDM writing
      INTEGER,PARAMETER   :: l_varselect=6
      CHARACTER(LEN=3)    :: s_code_observation(l_varselect)
      CHARACTER(LEN=3)    :: s_code_unit(l_varselect)
      CHARACTER(LEN=3)    :: s_code_value_significance(l_varselect)
      CHARACTER(LEN=3)    :: s_code_unit_original(l_varselect)
      CHARACTER(LEN=3)    :: s_code_conversion_method(l_varselect)
      CHARACTER(LEN=3)    :: s_code_conversion_flag(l_varselect)
      CHARACTER(LEN=10)   :: s_predef_numerical_precision(l_varselect)
      CHARACTER(LEN=10)   :: s_predef_hgt_obs_above_sfc(l_varselect)

      INTEGER             :: i_flag_segfault

      LOGICAL             :: there
c************************************************************************
      print*,'just entering process_qff_files20210216'

      print*,'l_files=',l_files

c      STOP 'near start process_qff_files2'
c*****
c     Get codes for variables to be processed
      CALL get_codes_processing_qff(l_varselect,
     +   s_code_observation,s_code_unit,
     +   s_code_value_significance,s_code_unit_original,
     +   s_code_conversion_method,s_code_conversion_flag,
     +   s_predef_numerical_precision,s_predef_hgt_obs_above_sfc)
c*****
c     Check last return & erase all files if index absent or 1

c     Read in last file number
      CALL readin_lastfile_number_qff(s_directory_output_lastfile,
     +  i_start)

      print*,'i_start=',i_start

c      STOP 'process_qff_files20210216'
c************************************************************************
c     Call test to find qff files not in stnconfig

c      GOTO 54

c      CALL test_qff_file_in_stnconfig(l_rgh_files,l_files,
c     +  s_vec_files,
c     +  l_scoutput_rgh,l_scoutput,l_scoutput_numfield,ilen,
c     +  s_scoutput_vec_header,s_scoutput_mat_fields,

c     +  l_cc_rgh,l_collect_cnt,
c     +  s_collect_primary_id,s_collect_record_number,
c     +  s_collect_secondary_id,s_collect_station_name,
c     +  s_collect_longitude,s_collect_latitude,
c     +  s_collect_height_station_above_sea_level,
c     +  s_collect_data_policy_licence,s_collect_source_id,

c     +  s_collect_region,s_collect_operating_territory,
c     +  s_collect_station_type,s_collect_platform_type,
c     +  s_collect_platform_sub_type,s_collect_primary_station_id_scheme,
c     +  s_collect_location_accuracy,s_collect_location_method,
c     +  s_collect_location_quality,s_collect_station_crs,
c     +  s_collect_height_station_above_local_ground,
c     +  s_collect_height_station_above_sea_level_acc,
c     +  s_collect_sea_level_datum,

c     +  s_collect_datalines)

c      STOP 'process_qff_files2; just after test_qff_file_in_stnconfig'

c 54   CONTINUE
c************************************************************************
      GOTO 55

c     Find index selected stations
c      s_stnlook='ASM00094108'
      s_stnlook='AMM00037897'

      DO i=1,l_files
       s_file_single=s_vec_files(i)

c       print*,'i...',i,TRIM(s_file_single)
c       STOP 'process_qff_files2'

c      Isolate single name from full path
       CALL isolate_single_name(s_file_single,s_stnname_isolated)

       IF (i.EQ.1) THEN
        print*,'first file:',TRIM(s_stnname_isolated)
       ENDIF

       IF (TRIM(s_stnname_isolated).EQ.TRIM(s_stnlook)) THEN
        print*,'i,s_stnlook=',i,TRIM(s_stnlook)
c        STOP 'process_qff_files2'
       ENDIF
      ENDDO

c      STOP 'file not found'

 55   CONTINUE
c************************************************************************
c      STOP 'process_gff_files2'

c     Cycle through station
      ii=0
      i_bad_test1_nostnlist=0
      i_bad_test2_floatconvert=0
      i_bad_test3_sourceid_prob=0
      i_bad_test4_segfault=0

      DO i=i_start,l_files !19000 !18000 !15000 !14000 !11000 !10000 !9000 !8000 !7000 !6000 !5000 !1000 !l_files !20000 !18000 !16000 !14000 !10001 !9500 !9000 !2001,3000
c 607,2000 !606,606 !600,600 !586,586 !601,2000 !586,586 !1,585 !1,1000 !i_start,l_files

       s_file_single=s_vec_files(i)

       print*,'i...',i,TRIM(s_file_single)

c       STOP 'process_qff_files2; A'

c      Isolate single name from full path
       CALL isolate_single_name(s_file_single,s_stnname_isolated)

       print*,'s_stnname_isolated=',TRIM(s_stnname_isolated)

c       STOP 'process_qff_files2; B'
c*****
c     Test if wishlist file in Robert Dunn directory
c     Inquire if file exists
      INQUIRE(FILE=TRIM(s_file_single),
     +  EXIST=there)

c     Skip analysis if file does not exist
      IF (.NOT.there) THEN

        CALL export_file_name(
     +    s_directory_output_diagnostics_notthere,s_stnname_isolated)

       GOTO 51
      ENDIF
c*****
c     Test if file is good
      i_flag_segfault=0
      CALL test_file_segfault(s_file_single,s_stnname_isolated,
     +   s_directory_output_diagnostics_segfault,
     +   s_directory_temp,
     +   i_flag_segfault)

c      print*,'process_qff_files20210216; cleared test_file_segfault'

c      Exit analysis & go to next station if flag set
       IF (i_flag_segfault.EQ.1) THEN
        i_bad_test4_segfault=i_bad_test4_segfault+1
        GOTO 51
       ENDIF
c*****
c      New method to get stnconfig information
c      print*,'l_scoutput=',l_scoutput
c      print*,'s_scoutput_searchname=',
c     +  (s_scoutput_searchname(j)//'=',j=1,5)

       CALL get_singles_stnconfig_qff20201012(
     +  i_flag,s_stnname_isolated,
     +  l_scoutput_rgh,l_scoutput,ilen,
     +  s_scoutput_stnconfig_lines,
     +  s_scoutput_header,s_scoutput_searchname,

     +  l_cc_rgh,l_collect_cnt,
     +  s_collect_primary_id,s_collect_record_number,
     +  s_collect_secondary_id,s_collect_station_name,
     +  s_collect_longitude,s_collect_latitude,
     +  s_collect_height_station_above_sea_level,
     +  s_collect_data_policy_licence,s_collect_source_id,

     +  s_collect_region,s_collect_operating_territory,
     +  s_collect_station_type,s_collect_platform_type,
     +  s_collect_platform_sub_type,s_collect_primary_station_id_scheme,
     +  s_collect_location_accuracy,s_collect_location_method,
     +  s_collect_location_quality,s_collect_station_crs,
     +  s_collect_height_station_above_local_ground,
     +  s_collect_height_station_above_sea_level_acc,
     +  s_collect_sea_level_datum,

     +  s_collect_datalines,s_collect_vec_header,l_collect_numfield)

c      Skip to next station if stconfig entry found
       IF (i_flag.EQ.1) THEN
        i_bad_test1_nostnlist=i_bad_test1_nostnlist+1
        GOTO 51
       ENDIF

c       print*,'l_collect_cnt=',l_collect_cnt
c       STOP 'process_qff_files20210216; C'
c*****
c      Process single qff file
       CALL process_single_qff_file20210216(s_file_single,
     +  l_rgh,l_lines,
     +  s_vec_station_id,s_vec_station_name,
     +  s_vec_year,s_vec_month,s_vec_day,
     +  s_vec_hour,s_vec_minute,
     +  s_vec_latitude,s_vec_longitude,s_vec_elevation,
     +  s_vec_airt_c,s_vec_airt_source_id,s_vec_airt_qc_flag,
     +  s_vec_dewp_c,s_vec_dewp_source_id,s_vec_dewp_qc_flag,
     +  s_vec_stnp_hpa,s_vec_stnp_source_id,s_vec_stnp_qc_flag,
     +  s_vec_slpr_hpa,s_vec_slpr_source_id,s_vec_slpr_qc_flag,
     +  s_vec_wdir_deg,s_vec_wdir_source_id,s_vec_wdir_qc_flag,
     +  s_vec_wspd_ms,s_vec_wspd_source_id,s_vec_wspd_qc_flag)

c       print*,'cleared process_single_qff_file20210216',l_lines
c*****
c      Find precision
       CALL find_original_precision_qff(l_rgh,l_lines,
     +   s_vec_airt_c,s_vec_dewp_c,
     +   s_vec_stnp_hpa,s_vec_slpr_hpa,
     +   s_vec_wdir_deg,s_vec_wspd_ms,

     +   s_vec_airt_origprec_c,s_vec_dewp_origprec_c,
     +   s_vec_stnp_origprec_hpa,s_vec_slpr_origprec_hpa,
     +   s_vec_wdir_origprec_deg,s_vec_wspd_origprec_ms,
     +   s_vec_airt_origprec_neglog,s_vec_dewp_origprec_neglog,
     +   s_vec_stnp_origprec_neglog,s_vec_slpr_origprec_neglog,
     +   s_vec_wdir_origprec_neglog,s_vec_wspd_origprec_neglog,
     +   s_vec_airt_origprec_empir_c,s_vec_dewp_origprec_empir_c,
     +   s_vec_stnp_origprec_empir_hpa,s_vec_slpr_origprec_empir_hpa,
     +   s_vec_wdir_origprec_empir_deg,s_vec_wspd_origprec_empir_ms)

c       print*,'cleared find_original_precision_qff'
c*****
c      Convert variable string to float
       CALL convert_var_string_to_float(i_flag,
     +   s_stnname_isolated,
     +   f_ndflag,l_rgh,l_lines,
     +   s_vec_airt_c,s_vec_dewp_c,
     +   s_vec_stnp_hpa,s_vec_slpr_hpa,
     +   s_vec_wdir_deg,s_vec_wspd_ms,

     +   f_vec_airt_c,f_vec_dewp_c,
     +   f_vec_stnp_hpa,f_vec_slpr_hpa,
     +   f_vec_wdir_deg,f_vec_wspd_ms)

c       print*,'cleared convert_var_string_to_float'

       IF (i_flag.EQ.1) THEN
        i_bad_test2_floatconvert=i_bad_test2_floatconvert+1
       ENDIF
c*****
c      Convert variables units from C to K & hPa to Pa
       CALL convert_units_qff(f_ndflag,
     +    l_rgh,l_lines,
     +    f_vec_airt_c,f_vec_dewp_c,
     +    f_vec_stnp_hpa,f_vec_slpr_hpa,
     +    s_vec_airt_origprec_empir_c,s_vec_dewp_origprec_empir_c,
     +    s_vec_stnp_origprec_empir_hpa,s_vec_slpr_origprec_empir_hpa,

     +    f_vec_airt_k,f_vec_dewp_k,
     +    f_vec_stnp_pa,f_vec_slpr_pa,
     +    s_vec_airt_k,s_vec_dewp_k,
     +    s_vec_stnp_pa,s_vec_slpr_pa,
     +    s_vec_airt_convprec_empir_k,s_vec_dewp_convprec_empir_k,
     +    s_vec_stnp_convprec_empir_pa,s_vec_slpr_convprec_empir_pa)

c       print*,'cleared convert_units_qff'
c*****
c      Find record number from source number
c       print*,'just before record_number_from_source_number_qff20200617'
c       print*,'s_directory_output_diagnostics',
c     +   TRIM(s_directory_output_diagnostics)
c       print*,'s_stnname_isolated',TRIM(s_stnname_isolated)
       i_flag=0
       CALL record_number_from_source_number_qff20200617b(
     +    s_directory_output_diagnostics,s_stnname_isolated,
     +    i_flag,
     +    l_cc_rgh,l_collect_cnt,
     +    s_collect_record_number,s_collect_source_id,
     +    l_rgh,l_lines,
     +    s_vec_airt_c,s_vec_dewp_c,
     +    s_vec_stnp_hpa,s_vec_slpr_hpa,
     +    s_vec_wdir_deg,s_vec_wspd_ms,
     +    f_vec_airt_c,f_vec_dewp_c,
     +    f_vec_stnp_hpa,f_vec_slpr_hpa,
     +    f_vec_wdir_deg,f_vec_wspd_ms,
     +    s_vec_airt_source_id,s_vec_dewp_source_id,
     +    s_vec_stnp_source_id,s_vec_slpr_source_id,
     +    s_vec_wdir_source_id,s_vec_wspd_source_id,

     +    s_vec_airt_recordnum,s_vec_dewp_recordnum,
     +    s_vec_stnp_recordnum,s_vec_slpr_recordnum,
     +    s_vec_wdir_recordnum,s_vec_wspd_recordnum)

c       print*,'cleared record_number_from_source_number'

c       print*,'i_flag=',i_flag
c       print*,'l_collect_cnt=',l_collect_cnt
c       print*,'s_collect_record_number=',
c     +   ('='//TRIM(s_collect_record_number(j))//'=',j=1,l_collect_cnt)
c       print*,'s_collect_source_id=',
c     +   ('='//TRIM(s_collect_source_id(j))//'=',j=1,l_collect_cnt)

c       STOP 'process_qff_files20201009'

c      Exit analysis & go to next station if flag set
       IF (i_flag.EQ.1) THEN
        i_bad_test3_sourceid_prob=i_bad_test3_sourceid_prob+1
        GOTO 51
       ENDIF
c*****
c      Find CDM QC codes
       CALL find_cdm_qc_code(l_rgh,l_lines,
     +    s_vec_airt_qc_flag,s_vec_dewp_qc_flag,
     +    s_vec_stnp_qc_flag,s_vec_slpr_qc_flag,
     +    s_vec_wdir_qc_flag,s_vec_wspd_qc_flag,

     +    s_vec_airt_cdmqc,s_vec_dewp_cdmqc,
     +    s_vec_stnp_cdmqc,s_vec_slpr_cdmqc,
     +    s_vec_wdir_cdmqc,s_vec_wspd_cdmqc)

c       print*,'cleared find_cdm_qc_code'
c*****
c     Place qc converter here
      CALL find_qc_pivot_table_info(l_rgh,l_lines,
     +    s_vec_airt_qc_flag,s_vec_dewp_qc_flag,
     +    s_vec_stnp_qc_flag,s_vec_slpr_qc_flag,
     +    s_vec_wdir_qc_flag,s_vec_wspd_qc_flag,
     +    s_vec_airt_cdmqc,s_vec_dewp_cdmqc,
     +    s_vec_stnp_cdmqc,s_vec_slpr_cdmqc,
     +    s_vec_wdir_cdmqc,s_vec_wspd_cdmqc,
     +    s_qckey_timescale_spec,l_qckey,
     +    s_qckey_sourceflag,s_qckey_c3sflag,s_qckey_timescale,

     +    s_vec_airt_cdmqcmethod,s_vec_dewp_cdmqcmethod,
     +    s_vec_stnp_cdmqcmethod,s_vec_slpr_cdmqcmethod,
     +    s_vec_wdir_cdmqcmethod,s_vec_wspd_cdmqcmethod)

c*****
c      print*,'s_vec_wdir_deg=',
c     +  ('|'//TRIM(s_vec_wdir_deg(k)),k=1,10)
c      print*,'s_vec_wdir_origprec_deg=',
c     +  ('|'//TRIM(s_vec_wdir_origprec_deg(k)),k=1,10)
c      print*,'s_vec_wdir_origprec_empir_deg=',
c     +  ('|'//TRIM(s_vec_wdir_origprec_empir_deg(k)),k=1,10)
c      print*,'s_vec_wdir_origprec_neglog=',
c     +  ('|'//TRIM(s_vec_wdir_origprec_neglog(k)),k=1,10)

c      print*,'s_vec_wspd_ms=',
c     +  ('|'//TRIM(s_vec_wspd_ms(k)),k=1,10)
c      print*,'s_vec_wspd_origprec_ms=',
c     +  ('|'//TRIM(s_vec_wspd_origprec_ms(k)),k=1,10)
c      print*,'s_vec_wspd_origprec_empir_ms=',
c     +  ('|'//TRIM(s_vec_wspd_origprec_empir_ms(k)),k=1,10)
c      print*,'s_vec_wspd_origprec_neglog=',
c     +  ('|'//TRIM(s_vec_wspd_origprec_neglog(k)),k=1,10)

c       STOP 'process_qff_files20200607'
c*****
c      CDM tables here

       CALL header_obs_lite_qff20210218(
     +   s_date_st,s_time_st,s_zone_st,

     +   s_directory_output_header,s_directory_output_observation,
     +   s_directory_output_lite,s_directory_output_receipt,
     +   s_directory_output_qc,s_directory_output_receipt_linecount,
     +   s_stnname_isolated,
     +   l_rgh,l_lines,
     +   s_vec_station_id,s_vec_station_name,
     +   s_vec_year,s_vec_month,s_vec_day,
     +     s_vec_hour,s_vec_minute,
     +     s_vec_latitude,s_vec_longitude,s_vec_elevation,
     +   s_vec_airt_c,s_vec_dewp_c,s_vec_stnp_hpa,s_vec_slpr_hpa,
     +     s_vec_wdir_deg,s_vec_wspd_ms,
     +   s_vec_airt_origprec_empir_c,s_vec_dewp_origprec_empir_c,
     +     s_vec_stnp_origprec_empir_hpa,s_vec_slpr_origprec_empir_hpa,
     +     s_vec_wdir_origprec_empir_deg,s_vec_wspd_origprec_empir_ms,
     +   f_vec_airt_c,f_vec_dewp_c,f_vec_stnp_hpa,f_vec_slpr_hpa,
     +     f_vec_wdir_deg,f_vec_wspd_ms,
     +   s_vec_airt_k,s_vec_dewp_k,s_vec_stnp_pa,s_vec_slpr_pa,
     +   s_vec_airt_convprec_empir_k,s_vec_dewp_convprec_empir_k,
     +     s_vec_stnp_convprec_empir_pa,s_vec_slpr_convprec_empir_pa,
     +   f_vec_airt_k,f_vec_dewp_k,f_vec_stnp_pa,f_vec_slpr_pa,
     +   s_vec_airt_source_id,s_vec_dewp_source_id,s_vec_stnp_source_id,
     +   s_vec_slpr_source_id,s_vec_wdir_source_id,s_vec_wspd_source_id,
     +   s_vec_airt_recordnum,s_vec_dewp_recordnum,s_vec_stnp_recordnum,
     +   s_vec_slpr_recordnum,s_vec_wdir_recordnum,s_vec_wspd_recordnum,
     +   s_vec_airt_cdmqc,s_vec_dewp_cdmqc,s_vec_stnp_cdmqc,
     +   s_vec_slpr_cdmqc,s_vec_wdir_cdmqc,s_vec_wspd_cdmqc,
     +    s_vec_airt_cdmqcmethod,s_vec_dewp_cdmqcmethod,
     +    s_vec_stnp_cdmqcmethod,s_vec_slpr_cdmqcmethod,
     +    s_vec_wdir_cdmqcmethod,s_vec_wspd_cdmqcmethod,
     +   l_varselect,s_code_observation,s_code_unit,
     +     s_code_value_significance,s_code_unit_original,
     +     s_code_conversion_method,s_code_conversion_flag,
     +     s_predef_hgt_obs_above_sfc,
     +   ilen,l_cc_rgh,l_collect_cnt,
     +     s_collect_primary_id,s_collect_record_number,
     +     s_collect_secondary_id,s_collect_station_name,
     +     s_collect_longitude,s_collect_latitude,
     +     s_collect_height_station_above_sea_level,
     +     s_collect_data_policy_licence,s_collect_source_id,
     +     s_collect_region,s_collect_operating_territory,
     +     s_collect_station_type,s_collect_platform_type,
     +     s_collect_platform_sub_type,
     +     s_collect_primary_station_id_scheme,
     +     s_collect_location_accuracy,s_collect_location_method,
     +     s_collect_location_quality,s_collect_station_crs,
     +     s_collect_height_station_above_local_ground,
     +     s_collect_height_station_above_sea_level_acc,
     +     s_collect_sea_level_datum,
     +   l_collect_numfield,s_collect_vec_header,s_collect_datalines)

        ii=ii+1

 51    CONTINUE       !entrance point one of bad flag tests

c       Export index of finished file
        CALL export_last_index_qff20200612(
     +   s_directory_output_lastfile,i,ii,
     +   i_values_st)
c*****
       print*,'INTERIM FLAG TALLY'
       print*,'i_bad_test1_nostnlist=',i_bad_test1_nostnlist
       print*,'i_bad_test2_floatconvert=',i_bad_test2_floatconvert
       print*,'i_bad_test3_sourceid_prob=',i_bad_test3_sourceid_prob
       print*,'i_bad_test4_segfault=',    i_bad_test4_segfault

      ENDDO

      print*,'just leaving process_qff_files'

      RETURN
      END

max_stars_repo_name: glamod/glamod-nuim

max_issues_repo_name: glamod/glamod-nuim

max_forks_repo_name: glamod/glamod-nuim


text:
      SUBROUTINE GRBVEC
C
C     THIS SUBROUITNE IS THE MAIN DRIVER FOR THE VECGRB MODULE
C     WHICH GENERATES
C
C     (1) THE GEOMETRIC RIGID BODY VECTORS ABOUT THE INDICATED GRID
C         POINT OR ORIGIN.
C         THIS SET OF VECTORS CONSISTS OF UNIT DISPLACEMENTS IN ZERO
C         COORDINATE SYSTEM ABOUT THE SPECIFIED GRID IN GLOBAL COORD.
C         FOR EASE OF ASSEMBLY THE VECTOR IS GENERATED IN THE TRANSPOSED
C         FORM, THAT IS, WITH SIX ROW, ONE FOR EACH OF THE SIX UNIT
C         MOTIONS AND G-SET COLUMNS, ONE FOR EACH DOF'S CORRESPONDING
C         MOTION. THIS SET OF VECTORS WOULD BE EXACTLY EQUAL TO A UNIT
C         DISPLACEMENT CHECK IF ALL THE GRIDS HAD STIFFNESS BUT WERE
C         NOT GROUNDED.
C
C     (2) A g-SET SIZED CSTM FROM BASIC TO GOLBAL
C
C     DMAP SEQUENCE -
C
C     VECGRB    BGPDT,EQEXIN,CSTM/OUTVEC/P1/P2/P3   $
C
C     WHERE     P1 = 1, GENERATE CSTM FROM BASIC TO GLOBAL
C                  = 2, GENERATE PHIRBT
C               P2 = REFERENCE GRID FOR PHIRB (0=BASIC, DEFAULT)
C               P3 = CURRENTLY NOT USED
C
C     EXAMPLES -
C
C     (1) G-SET EQUILIBRIUM CHECK
C     THIS CHECK MULTIPLIES THE STIFFNESS MATRIX TIMES THE GEOMETRIC
C     RIGID BODY SHAPES PENERATED BY VECRGB. THE FORCES OBATINED FROM
C     THIS MULTIPLICATION SHOULD BE ZERO.
C
C     VECGRB   BGPDT,CSTM,EQEXIN/PHIRBT/2/0  $ CREATE TRANSPOSE OF RIGID
C     TRNSP    PHIRBT/PHIRB                  $ BODY VECTORS, THEN TRNSP
C     MPYAD    KGG,PHIRB,/KPHIG/0            $ MULTIPLY BY STIFFNESS.
C     MPYAD    PHIRBT,KPHIG,/KPHG6/0         $ SUM FORCES AND PRINT
C     MATPRN   KPHG6,,,, //                  $ 6X6 SUMMATION. PRINT ALL
C     MATGPR   GPL,USET,SIL,KPHIG//*G*/*G*// $ FORCES OVER 0.0001
C              .0001                         $
C
C     (2) COORDINATE SYSTEM TRANSFORMATION
C
C     VECRGB   BGPDT,CSTM,EQEXIN/BCSTM/1     $ TRANSFORM GLOBAL KGG TO
C     TRNSP    BCSTM/BCSTMT/                 $ BASIC
C     MPYAD    BCSTM,KGG,/BGKGG/0            $
C     MPYAD    BGKGG,BCSTMT,/BBKGG/0         $
C
C     THIS SUBROUTINE WAS ORIGINALLY CALLED CSTMX, AND WAS WRITTEN BY
C     P.KIRCHMAN/SWALES, 2/1993, WITH THE DMAP MODULE OF THE SAME NAME
C
C     THE DMAP MODLUE IS RENAMED TO GEOMETRIC RIGID BODY VECTOR, VECGRB,
C     AND THE SUBROUTINE GRBVEC. THE ORIGINAL SUBROUTINE WAS RE-CODED BY
C     G.CHAN/UNISIS, USING NASTRAN TRADITIONAL FORTRAN STYLE, AND THE
C     SUBSTITUTION OF GMMATD ROUTINE FOR DP3X3M. ALSO, THE ORDER OF 2ND
C     AND 3RD INPUT DATA BLOCKS IS INTERCHANGED.
C
C     THE ORIGINAL CSTMX IS INCLUDED IN THE 1993 RELEASE. IT IS ONLY
C     FOR BACKUP PURPOSE. CSTMX WILL BE DELETED IN NEXT NASTRAN RELEASE
C     (THE ORIGINAL CSTMX ROUTINE PRODUCED HUNDREDS OF FORTRAN ERRORS
C     ON CDC MACHINE WITH FTN5 COMPILER. 3/93)
C
      IMPLICIT INTEGER (A-Z)
      LOGICAL          RBV
      INTEGER          TRL(7),NAME(2),SUB(2)
      REAL             RX(1)
      DOUBLE PRECISION RBVR(3),V3(3),ZERO,ONE,XG,YG,ZG,RAD,XL,TU(9),
     1                 T1(9),T2(9),T(9),RVEC(9),RBVEC(9),V(3),VOUT(6)
      CHARACTER        UFM*23,UWM*25,UIM*29,SFM*25
      COMMON /XMSSG /  UFM,UWM,UIM,SFM
      COMMON /BLANK /  P1,P2,P3
      COMMON /ZZZZZZ/  IX(1)
      COMMON /SYSTEM/  IBUFF,NOUT
      COMMON /PACKX /  TIN,TOU,II,JJ,INCR
      EQUIVALENCE      (IX(1),RX(1))
      DATA    BGPDT ,  EQEXIN, CSTM / 101,102,103  /,
     1        OUTVEC/  201 /,  SUB  / 4HGRBV,4HC   /
      DATA    ZERO  ,  ONE /  0.0D+0, 1.0D+0       /
      DATA    CSTMX ,  EQE,XIN,       BGP,DT       /
     1        4HCSTM,  4HEQEX,4HIN  , 4HBGPD,4HT   /
C
C     CHECK FOR THE PRESENCE OF OUTPUT DATA BLOCK
C
      TRL(1) = OUTVEC
      CALL RDTRL (TRL)
      IF (TRL(1) .LE. 0) GO TO 1000
C
C     INITIALIZATION
C
      LCOR  = KORSZ(IX(1)) - IBUFF
      BUF1  = LCOR - 1
      TU(1) = ONE
      TU(2) = ZERO
      TU(3) = ZERO
      TU(4) = ZERO
      TU(5) = ONE
      TU(6) = ZERO
      TU(7) = ZERO
      TU(8) = ZERO
      TU(9) = ONE
C
C     CHECK THE PRESENCE OF BGPDT AND CSTM FILES
C
      TRL(1)= BGPDT
      CALL RDTRL (TRL)
      IF (TRL(1) .LE. 0) GO TO 1020
      NENT  = TRL(2)
      TRL(1)= CSTM
      CALL RDTRL (TRL)
      NCST  = TRL(3)
      IF (TRL(1) .LE. 0) NCST = 0
      NENT4 = NENT*4
      NCST14= NCST*14
      IF (NENT4+NCST14 .GT. LCOR) GO TO 1100
      RBV   = P1 .EQ. 2
C
C     CHECK IF THIRD INPUT FILE IS PRESENT, THEN OPEN EQEXIN FILE AND
C     READ THE FIRST TABLE INTO CORE IF APPROPRIEATE
C
      GRDPNT = 0
      IF (P1.NE.2 .OR. P2.EQ.0) GO TO 60
      TRL(1) = EQEXIN
      CALL RDTRL (TRL)
      IF (TRL(1) .LE. 0) GO TO 1020
      FILE = EQEXIN
      CALL FNAME (EQEXIN,NAME)
      IF (NAME(1).NE.EQE .OR. NAME(2).NE.XIN) GO TO 1040
      CALL OPEN (*1200,EQEXIN,IX(BUF1),0)
      CALL FWDREC (*1300,EQEXIN)
      CALL READ (*1300,*20,EQEXIN,IX(1),BUF1-1,1,FLAG)
      CALL MESAGE (-8,0,SUB)
   20 TRL2 = TRL(2)*2
      IF (FLAG .NE. TRL2) GO TO 1320
      J = 1
      DO 30 I = 1,TRL2,2
      IF (P2 .NE. IX(J)) GO TO 30
      GRDPNT = IX(J+1)
      GO TO 50
   30 J = J + 2
      GRDPNT = 0
      WRITE  (NOUT,40) UWM,P2
   40 FORMAT (A25,' - ID ',I8,' IS NOT A GRID POINT.  THE ORIGIN WILL ',
     1       'BE USED.')
   50 CALL CLOSE (EQEXIN,1)
C
C     OPEN AND READ BGPDT TABLE INTO BEGINNING OF CORE
C
   60 FILE = BGPDT
      CALL FNAME (BGPDT,NAME)
      IF (NAME(1).NE.BGP .AND. NAME(2).NE.DT) GO TO 1040
      CALL OPEN (*1200,BGPDT,IX(BUF1),0)
      CALL FWDREC (*1300,BGPDT)
      CALL READ (*1300,*70,BGPDT,IX(1),BUF1-1,1,FLAG)
      CALL MESAGE (-8,0,SUB)
   70 IF (FLAG .NE. NENT4) GO TO 1330
      CALL CLOSE (BGPDT,1)
C
C     OPEN AND READ CSTM FIRST TABLE INOT CORE AFTER BGPDT
C
      IF (NCST .EQ. 0) GO TO 90
      FILE = CSTM
      CALL FNAME (CSTM,NAME)
      IF (NAME(1) .NE. CSTMX) GO TO 1040
      CALL OPEN (*1200,CSTM,IX(BUF1),0)
      CALL FWDREC (*1300,CSTM)
      CALL READ (*1300,*80,CSTM,IX(NENT4+1),BUF1-NENT4-1,1,FLAG)
      CALL MESAGE (-8,0,SUB)
   80 IF (FLAG .NE. NCST14) GO TO 1340
      CALL CLOSE (CSTM,1)
C
C     USE BGPDT INFO TO FIGURE OUT THE g-SET SIZE FOR OUTPUT
C
   90 SIZE = 0
      I    = 1
      DO 100 J = 1,NENT
      IF (IX(I) .LT. 0) SIZE = SIZE + 1
      IF (IX(I) .GE. 0) SIZE = SIZE + 6
  100 I = I + 4
C
C     STORE RIGID BODY REFERENCE VECTOR
C
      RBVR(1) = 0.
      RBVR(2) = 0.
      RBVR(3) = 0.
      IF (.NOT.RBV .OR. GRDPNT.EQ.0) GO TO 110
      RBVR(1) = RX(GRDPNT*4-2)
      RBVR(2) = RX(GRDPNT*4-1)
      RBVR(3) = RX(GRDPNT*4  )
C
C     OPNE OUTPUT FILE AND FILL OUTPUT TRAILER
C
  110 CALL FNAME (OUTVEC,NAME)
      CALL OPEN (*1200,OUTVEC,IX(BUF1),1)
      CALL WRITE (OUTVEC,NAME,2,1)
      IF (     RBV) CALL MAKMCB (TRL(1),OUTVEC,6,2,2)
      IF (.NOT.RBV) CALL MAKMCB (TRL(1),OUTVEC,SIZE,2,2)
C
C     INITIALIZE PACK COMMONS
C
      TIN  = 2
      TOU  = 2
      INCR = 1
      COL  = 1
C
C     BEGIN LOOP FOR NUMBER OF ENTRIES IN BGPDT
C
      E4  = 0
      DO 440 ENTRY = 1,NENT
      E4  = E4 + 4
      OCID= IX(E4-3)
      XG  = RX(E4-2)
      YG  = RX(E4-1)
      ZG  = RX(E4  )
C
C     RBVEC IS A VECTOR BASED ON UNIT ROTATIONS OF A VECTOR FROM THE
C     REFERENCE GRID TO THE GRID IN QUESTION. THE TRANSFORMATION IS
C     FROM BASIC ROTATIONS TO BASIC TRANSLATIONS.
C
      IF (.NOT.RBV) GO TO 130
      RVEC(1) = ZERO
      RVEC(2) = (ZG-RBVR(3))
      RVEC(3) =-(YG-RBVR(2))
      RVEC(4) =-(ZG-RBVR(3))
      RVEC(5) = ZERO
      RVEC(6) = (XG-RBVR(1))
      RVEC(7) = (YG-RBVR(2))
      RVEC(8) =-(XG-RBVR(1))
      RVEC(9) = ZERO
C
C     IF THIS ENTRY IS A SCALAR AND A RIGID BODY VECTOR HAS BEEN
C     REQUESTED, STORE A ZERO COLUMN
C
 130  IF (OCID.NE.-1 .OR. .NOT.RBV) GO TO 140
      II  = 1
      JJ  = 1
      CALL PACK (ZERO,OUTVEC,TRL)
      COL = COL + 1
      GO TO 440
C
C     IF THIS ENTRY IS A SCALAR AND A CSTM HAS BEEN REQUESTED, SIMPLY
C     PLACE A ONE ON THE DIAGONAL AND CONTINUE
C
  140 IF (OCID .NE. -1) GO TO 150
      II  = COL
      JJ  = COL
      CALL PACK (ONE,OUTVEC,TRL)
      COL = COL + 1
      GO TO 440
C
C     IF THIS ENTRY IS ALREADY IN BASIC COORDINATES, STORE AN IDENTITY
C     IN THE APPOPRIATE SIX BY SIX
C
  150 IF (OCID.NE.0 .OR. .NOT.RBV) GO TO 190
      II  = 1
      JJ  = 1
      DO 170 I = 1,3
      I3  = 0
      DO 160 J = 1,3
      VOUT(J  ) =   TU(J+I*3)
  160 VOUT(J+3) = RVEC(J+I*3)
      I3  = I3 + 3
      II  = 1
      JJ  = 6
      CALL PACK (VOUT,OUTVEC,TRL)
  170 COL = COL + 1
      DO 180 I = 1,3
      II  = I + 3
      JJ  = I + 3
      CALL PACK (ONE,OUTVEC,TRL)
  180 CONTINUE
      GO TO 440
C
  190 IF (OCID .NE. 0) GO TO 210
      DO 200 I = 1,6
      II  = COL
      JJ  = COL
      CALL PACK (ONE,OUTVEC,TRL)
  200 COL = COL + 1
      GO TO 440
C
C     CSTM MUST BE MISSING
C
  210 IF (NCST .NE. 0) GO TO 220
      TRL(1) = CSTM
      GO TO 1020
C
C     SET UP VECTORS AND MATRICES COMMON TO ALL COORDINATE SYSTEM
C     TRANSFORMATIONS
C
C     FIND COORDINATE SYSTEM
C
  220 DO 230 ICST = 1,NCST
      IF (IX(ICST*14-13+NENT4) .EQ. OCID) GO TO 240
  230 CONTINUE
      GO TO 1400
C
C     GET COORDINATE SYSTEM TYPE AND
C     TRANSFORMATION FROM BASIC TO COORDINATE SYSTEM ORIGIN TRIAD
C
  240 OCIDT = IX(ICST*14-12+NENT4)
      T1(1) = RX(ICST*14- 8+NENT4)
      T1(4) = RX(ICST*14- 7+NENT4)
      T1(7) = RX(ICST*14- 6+NENT4)
      T1(2) = RX(ICST*14- 5+NENT4)
      T1(5) = RX(ICST*14- 4+NENT4)
      T1(8) = RX(ICST*14- 3+NENT4)
      T1(3) = RX(ICST*14- 2+NENT4)
      T1(6) = RX(ICST*14- 1+NENT4)
      T1(9) = RX(ICST*14   +NENT4)
C
      IK    = ICST*14 + NENT4
      V3(1) = RX(ENTRY*4-2) - RX(IK-11)
      V3(2) = RX(ENTRY*4-1) - RX(IK-10)
      V3(3) = RX(ENTRY*4  ) - RX(IK- 9)
C
      V(1)  = RX(IK-8)*V3(1) + RX(IK-5)*V3(2) + RX(IK-2)*V3(3)
      V(2)  = RX(IK-7)*V3(1) + RX(IK-4)*V3(2) + RX(IK-1)*V3(3)
      V(3)  = RX(IK-6)*V3(1) + RX(IK-3)*V3(2) + RX(IK  )*V3(3)
C
C     SPECIAL CHECKS FOR ZERO RADIUS CYLINDRICAL OR SPHERICAL COORDINATE
C     SYSTEM. IF SO TREAT AS RECTANGULAR.
C
      RAD = SQRT(V(1)**2 + V(2)**2)
      IF (RAD .EQ. 0.) OCIDT = 1
C
C     PERFORM INDIVIDUAL COORDINATE SYSTEM TRANSFORMATION AND GENERATE
C     T2
C
      GO TO (250,330,340), OCIDT
C
C     RECTANGULAR, T = T1
C
  250 IF (.NOT.RBV) GO TO 290
      INDEX = 1
      CALL GMMATD (RVEC,3,3,0, T1,3,3,0, RBVEC)
C
C     ADD RIGID BODY INFORMATION TO LOWER OFF DIAGONAL 3X3 IF REQUESTED
C
      DO 280 I = 1,3
      I3  = 0
      DO 270 J = 1,3
      VOUT(J  ) =    T1(J+I3)
  270 VOUT(J+3) = RBVEC(J+I3)
      I3  = I3 + 3
      II  = 1
      JJ  = 6
      CALL PACK (VOUT,OUTVEC,TRL)
  280 COL = COL + 1
      GO TO 310
C
C     OR SIMPLY PACK THE TRANSFORMATION
C
  290 INDEX = COL
      DO 300 I = 1,3
      II  = INDEX
      JJ  = INDEX + 2
      CALL PACK (T1(I*3-2),OUTVEC,TRL)
  300 COL = COL + 1
C
C    STORE LOWER 3X3, AND GET NEXT GRID
C
  310 DO 320 I = 1,3
      II  = INDEX + 3
      JJ  = INDEX + 5
      CALL PACK (T1(I*3-2),OUTVEC,TRL)
  320 COL = COL + 1
      GO TO 440
C
C     CYLINDRICAL
C
  330 T2(1) = V(1)/RAD
      T2(4) =-V(2)/RAD
      T2(7) = ZERO
      T2(2) =-T2(4)
      T2(5) = T2(1)
      T2(8) = ZERO
      T2(3) = ZERO
      T2(6) = ZERO
      T2(9) = ONE
      GO TO 350
C
C     SPHERICAL
C
  340 XL    = SQRT(V(1)*V(1) + V(2)*V(2) + V(3)*V(3))
      IF (XL .LE. 0.0) GO TO 1060
      T2(1) = V(1)/XL
      T2(4) =(V(1)*V(3))/(RAD*XL)
      T2(7) =-V(2)/RAD
      T2(2) = V(2)/XL
      T2(5) =(V(2)*V(3))/(RAD*XL)
      T2(8) = V(1)/RAD
      T2(3) = V(3)/XL
      T2(6) =-RAD/XL
      T2(9) = ZERO
C
  350 CALL GMMATD (T1,3,3,0, T2,3,3,0, T)
      IF (.NOT.RBV) GO TO 400
C
C     ADD RIGID BODY INFORMATION TO LOWER OFF DIAGONAL 3X3 IF REQUESTED
C     THEN PACK
C
      INDEX = 1
      CALL GMMATD (RVEC,3,3,0, T,3,3,0, RBVEC)
      DO 390 I = 1,3
      I3  = 0
      DO 380 J = 1,3
      VOUT(J  ) =     T(J+I3)
  380 VOUT(J+3) = RBVEC(J+I3)
      I3  = I3 + 3
      II  = 1
      JJ  = 6
      CALL PACK (VOUT,OUTVEC,TRL)
  390 COL = COL + 1
      GO TO 420
C
C     OR SIMPLY PACK THE TRANSFORMATION
C
  400 INDEX = COL
      DO 410 I = 1,3
      II  = INDEX
      JJ  = INDEX + 2
      CALL PACK (T(I*3-2),OUTVEC,TRL)
  410 COL = COL + 1
C
C     STORE LOWER 3X3
C
  420 DO 430 I = 1,3
      II  = INDEX + 3
      JJ  = INDEX + 5
      CALL PACK (T(I*3-2),OUTVEC,TRL)
  430 COL = COL + 1
C
  440 CONTINUE
C
      CALL CLOSE  (OUTVEC,1)
      CALL WRTTRL (TRL)
      RETURN
C
C     ERRORS
C
 1000 WRITE  (NOUT,1010) UFM
 1010 FORMAT (A23,'.  MISSING REQUIRED OUTPUT FILE')
      GO TO  1500
 1020 WRITE  (NOUT,1030) UFM,TRL(1)
 1030 FORMAT (A23,'.  MISSING REQUIRED INPUT FILE',I4)
      GO TO  1500
 1040 WRITE  (NOUT,1050) UFM,NAME
 1050 FORMAT (A23,'. INPUT FILE ',2A4,' ERROR')
      GO TO  1500
 1060 WRITE  (NOUT,1070) UFM
 1070 FORMAT (A23,' FROM GRBVEC. ZERO RADIAL LENGTH, ERROR AT 340')
      GO TO  1500
 1100 J = -8
      GO TO  1490
 1200 J = -1
      GO TO  1490
 1300 J = -2
      GO TO  1490
 1320 J = TRL2
      GO TO  1350
 1330 J = NENT4
      GO TO  1350
 1340 J = NCST14
 1350 WRITE  (NOUT,1360) SFM,NAME,J,FLAG
 1360 FORMAT (A25,'. EXPECTED RECORD LENGTH DOES NOT MATCH ACTUAL ',
     1       ' RECORD LENGTH ON INPUT FILE ',2A4, /5X,2I10)
      GO TO  1500
 1400 WRITE  (NOUT,1410) UFM,OCID
 1410 FORMAT (A23,'. UNABLE TO FIND COORDINATE SYSTEM ',I8)
      GO TO  1500
C
 1490 CALL MESAGE (J,FILE,SUB)
 1500 CALL MESAGE (-61,0,SUB)
      RETURN
      END

ext: f


text:
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

C $Id: eval_g.f,v 1.1 2002/05/02 18:52:13 andreasw Exp $
      subroutine EVAL_G(N, X, G)
C
C     Gradient of objective function for IPOPT
C     Linear terms that we defined in DYNOPC.INC
C
C     Authors:  Yidong Lang, Andreas Waechter     09-29-01
C
      implicit none
      integer N
      double precision G(N), X(N)

      include 'DYNAUX.INC'
      include 'DYNOPC.INC'
!DEC$ ATTRIBUTES DLLEXPORT :: /DYNAUX/, /DYNOPC/

      integer i, iex, j

      call DCOPY(N, 0.d0, 0, G, 1)

      do i = 1, NE_IN_OBJ
         iex = (E_INDEX(i)-1)*(NCOL*(NZ+NY) + NZ)
         do j = 1, NZ_IN_OBJ
            G(iex+Z_INDEX(j)) = AIJZ(j,i)
         end do
         iex = iex - NY
         do j = 1, NY_IN_OBJ
            G(iex+Y_INDEX(j)) = BIJY(j,i)
         end do
      end do

      iex = NZ + NELE*(NCOL*(NZ+NY)+NZ)+NELE*NCOL*NU
      do i = 1, NP_IN_OBJ
          G(iex+P_INDEX(i)) = CIP(i)
      end do

      return
      end

max_stars_repo_name: kant/CMMPPT

max_issues_repo_name: kant/CMMPPT

max_forks_repo_name: kant/CMMPPT


text:
! { dg-do compile }
! Check that private entities in public namelists are rejected
module namelist_1
  public
  integer,private :: x
  namelist /n/ x ! { dg-error "cannot be member of PUBLIC namelist" "" }
end module

! { dg-final { cleanup-modules "namelist_1" } }

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab