PROGRAM READS4 C c Notes to users - Program READS4 was originally developed for the CDC Cyber c machines; the following version has been modified c twice - once to run on a UNIX system and read files which c were produced on this UNIX system (these changes are c identified in code as "unix conversion") ,and a second c time to read an image from the optical disk (these c changes are identified as "daac conversion"). Lines c of code which needed changes were commented out and new c lines added in case other systems need the original c information. c c Some things to notice about this program: c c c 1. The subroutine STUFF has been modified and now calls c C routines which are in the file GBYTES.C. c c c 2. The FORTRAN "open" and "read" statements have been c replaced with C routines "copen" and "cread" which are in c the file io.c. c c 4. The S-4 contains 26 separate files. This program c is designed to read the header, the scale c factors, and one of the data files per run. Before using c this program, the S-4 product is separated into 26 files c with these names: c C file1 = HEADER C file2 = SCANNER SCALE FACTORS C file3 = NONSCANNER SCALE FACTORS C file4 = NFOV INPUT DATA C file5 = NFOV 5.0 DEG. NESTED DATA C file6 = NFOV 10.0 DEG. NESTED DATA C file7 = NFOV 2.5 DEG. ZONAL DATA C file8 = NFOV 5.0 DEG. ZONAL DATA C file9 = NFOV 10.0 DEG. ZONAL DATA C file10 = NFOV GLOBAL DATA C file11 = MFOV-NF INPUT DATA C file12 = MFOV-NF 10.0 DEG. NESTED DATA C file13 = MFOV-NF 5.0 DEG. ZONAL DATA C file14 = MFOV-NF 10.0 DEG. ZONAL DATA C file15 = MFOV-NF GLOBAL DATA C file16 = WFOV-NF INPUT DATA C file17 = WFOV-NF 10.0 DEG. NESTED DATA C file18 = WFOV-NF 5.0 DEG. ZONAL DATA C file19 = WFOV-NF 10.0 DEG. ZONAL DATA C file20 = WFOV-NF GLOBAL DATA C file21 = MFOV-SF INPUT DATA C file22 = MFOV-SF 10.0 DEG. ZONAL DATA C file23 = MFOV-SF GLOBAL DATA C file24 = WFOV-SF INPUT DATA C file25 = WFOV-SF 10.0 DEG. ZONAL DATA C file26 = WFOV-SF GLOBAL DATA C C $SPECS INST IRES IMF ICOVRG ,IRECF IRECL C file4 s4_04_sc2.5_84112 1 1 2 1 2145 2145 C file10 s4_10_scglb_84112 1 2 1 3 1 1 C file11 s4_11_mnf5.0_84112 2 1 1 1 1145 1145 C file21 s4_21_msf10_84112 2 3 1 1 145 145 C file22 s4_22_msf10z_84112 2 3 1 2 5 5 C file23 s4_23_msfglb_84112 2 3 1 3 1 5 C file24 s4_24_wsf10_84112 2 3 2 1 145 145 C file25 s4_25_wsf10z_84112 2 3 2 2 5 5 c file26 s4_26_wsfglb_84112 2 3 2 3 1 5 C C Above are examples of input setup file s4namls. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NAME - READS4 C LANGUAGE - FORTRAN V TYPE- PROGRAM C VERSION - 3.0 UPDATE- 2/88 PROGRAMMER- Jill Travers C VERSION - 4.0 UPDATE- 2/93 PROGRAMMER- Libby Smith C VERSION - 5.0 UPDATE- 3/93 PROGRAMMER- Libby Smith c VERSION - 6.0 UPDATE- 5/94 PROGRAMMER- Enakshi Singh CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO READ, UNPACK AND SELECTIVELY PRINT OUT C PORTIONS OF THE S-4 OUTPUT PRODUCT. C C NOTE: SEE BLOCK DATA SECTION FOR INSTRUCTIONS ON HOW TO USE C THIS PROGRAM. C C INPUT FILES: NAMELIST FILES (ON UNITS 50 AND 51) C OUTPUT FILES: TAPE9 TO SHOW REQUESTED DATE FROM DUMPS C C COMMON BLOCKS: /CHARCM/, /DATLOC/, /DESCRP/, /DATRAY/, /NMPARAM/, C /GLOBAL/, /HEADER/, /RECLOC/, /FILLOC/, /S4IO/ C SEE BLOCK DATA FOR DESCRIPTION OF EACH COMMON BLOCK C C NAMELISTS C $SPECS- C INST - INSTRUMENT CODE 1=SCANNER 2=NONSCANNER C IRES - RESOLUTION 1=2.5 2=5.0 3=10.0 DEGREES C IMF - FIELD OF VIEW C ICOVRG-1=REGIONAL 2=ZONAL 3=GLOBAL C IRECF- FIRST RECORD TO DUMP (REGION NUMBER) C IRECL- LAST RECORD TO DUMP (REGION NUMBER) C IRAY - ARRAY SPECIFYING WHICH TYPE OF VALUES TO DUMP C 1= MONTHLY(DAY) 2= MONTHLY(HOUR) C 3= DAILY 4= HOURLY C IDATA- ARRAY INDICATING WHICH DATA TO DUMP C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C CCCCC CHARACTER STATEMENTS C CHARACTER SCNNAM*37, NSCNAM*32 CHARACTER IHDMP(11)*30,ISCNAM(3)*8,CVAR*60 C LOGICAL IERR, DOREP,DOFILE C CCCCC COMMON BLOCKS C COMMON /CHARCM/ IHDMP,ISCNAM,CVAR COMMON /DATLOC/ NSCBEG(29),NSCEND(29),ISCBEG(49),ISCEND(49), 2 ISCMAX(7), INSMAX(16), ISCNDX(49), NSINDX(29), 3 ISCITM, INSITM COMMON /DESCRP/ SCNNAM(49), NSCNAM(29) COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /NMPARAM/ INST, IRES, IMF, ICOVRG, IRECF, IRECL, 1 IRAY(4),IDATA(9) COMMON /GLOBAL/ ISUBNO,IVERSN,MSGUNT,IVAR(3),RVAR(3) COMMON /HEADER/ IYR,IMO,ISPACE,INSTCD COMMON /RECLOC/ ISCREC(7), LSCREC(7), 1 INSREC(16), LNSREC(16) COMMON /FILLOC/ ISCFIL(7), INSFIL(16) COMMON /S4IO/ IOS4, NFILE, NPKS4,IERR,DOREP, DOFILE, IDB c +++ c daac conversion - read ERBE header' c +++ integer string(30) C DATA ISCNAM / 'NOAA 9', 'ERBS', 'NOAA10'/ DATA IND /0/ C CCCCC DECLARE NAMELISTS OPEN AND READ CCCCCCCCCCCC C NAMELIST /SPECS/ INST,IRES,IMF,ICOVRG,IRECF,IRECL,IRAY,IDATA C C OPEN OUTPUT FILES C OPEN (NPKS4,IOSTAT=IOS,ERR=333) OPEN (IDB,IOSTAT=IOS,ERR=333) C CCCCC READ THE NAMELIST c OPEN (50,file ='s4namls',IOSTAT=IOS) write(77,*) ios READ (50,SPECS,IOSTAT=IOS) WRITE (NPKS4,SPECS,IOSTAT=IOS) CLOSE (50,IOSTAT=IOS) C C *** INITIALIZE VALUES C IERR = .FALSE. msgunt = 95 IOS4=8 c +++ c daac conversion - read erbe header using C routines, copen and cread c +++ CALL COPEN('file1',5,IUNH) CALL CREAD(IUNH,30,STRING,IOS) if(ios.ne.30) then go to 222 endif C C *** GET SCANNER SCALE FACTORS c +++ c daac conversion - call C open routine instead of using FORTRAN open c +++ C call copen('file2',5,isccal) call scnscl (isccal) WRITE(77,6543) 6543 FORMAT('IERR, ',I5) WRITE(77,*) IERR IF (IERR) GOTO 999 C C *** GET THE NONSCANNER SCALE FACTORS C call copen('file3',5,inscal) CALL NSCSCL (inscal) IF (IERR) GOTO 999 IF (INST.EQ.1) THEN CALL SCNINIT ELSE CALL NSCINIT ENDIF C C *** READ THE SCANNER FILES C DO 100 IFILE = 1,7 IF (ISCFIL(IFILE).EQ.1) THEN PRINT *,'*** NOW PROCESSING SCANNER FILE ***' CALL SCNFIL(IFILE) IF(IERR) GOTO 999 ENDIF 100 CONTINUE C C *** READ THE NONSCANNER FILES C DO 150 IFILE = 1,16 IF (INSFIL(IFILE).EQ.1) THEN PRINT *,'*** NOW PROCESSING NONSCANNER FILES ***' CALL NSCFIL(IFILE) IF(IERR) GOTO 999 ENDIF 150 CONTINUE C GOTO 999 C 222 WRITE (NPKS4,1005) IOS 1005 FORMAT (' ',5X,'read FILE ERROR on header file ',/, 1 5X,' IOS = ',I6) GOTO 999 c 333 WRITE (NPKS4,1000) IOS 1000 FORMAT (' ',5X,'OPEN FILE ERROR IN READS4 ',/, 1 5X,' IOS = ',I6) GOTO 999 C 441 WRITE (NPKS4,451) IFILE,IOS 451 FORMAT (' ',5X,'OPEN ERROR ON SCANNER FILE ',I1,/, 1 5X,' IOS = ',I6) GOTO 999 C 442 WRITE (NPKS4,452) IFILE,IOS 452 FORMAT (' ',5X,'OPEN ERROR ON NONSCANNER FILE ',I1,/, 1 5X,' IOS = ',I6) GOTO 999 C 551 WRITE (NPKS4,561) IFILE,IOS 561 FORMAT (' ',5X,'READ ERROR ON SCANNER FILE ',I1,/, 1 5X,' IOS = ',I6) GOTO 999 C 552 WRITE (NPKS4,562) IFILE,IOS 562 FORMAT (' ',5X,'READ ERROR ON NONSCANNER FILE ',I1,/, 1 5X,' IOS = ',I6) GOTO 999 c 661 WRITE (NPKS4,671) IFILE,IOS 671 FORMAT (' ',5X,'CLOSE ERROR ON SCANNER FILE ',I1,/, 1 5X,' IOS = ',I6) GOTO 999 C 662 WRITE (NPKS4,672) IFILE,IOS 672 FORMAT (' ',5X,'CLOSE ERROR ON NONSCANNER FILE ',I1,/, 1 5X,' IOS = ',I6) GOTO 999 C 777 WRITE (NPKS4,1100) IOS 1100 FORMAT (' ',5X,'CLOSE FILE ERROR IN READS4 ',/, 1 5X,' IOS = ',I6) c 5000 FORMAT (' ',5X,'S4 TAPE DUMP FOR ',I2,'-',I2,/, 1 ' SATELLITE CODE = ',I1) C C *** TERMINATE PROCESSING C 999 ITERM = 0 C END C C BLOCK DATA S4BLK C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C CCCCC DEFINITIONS AND INITIALIZATIONS OF VARIABLES USED IN THE CCCCC READS4 PROGRAM. CCCCC CCCCC 1. CAN ACCESS 1 FILE AT A TIME CCCCC CCCCC 2. CAN ACCESS A RANGE OF RECORDS IN EACH CCCCC FILE CCCCC CCCCC 3. CAN ACCESS 1 DATA ITEMS, ALL DATA ITEMS, OR ONLY CCCCC CERTAIN DATA ITEMS IN THE INDICATED RECORDS. CCCCC CCCCC 4. CAN CREATE FORMATTED LISTINGS OR UNFORMATTED CCCCC LISTINGS OF THE PROCESSED RECORDS. CCCCC C CCC COMMON BLOCKS USED C C /DATLOC/ C C NSCBEG(29)--------BEGINNING POSITIONS OF THE DATA ITEMS IN THE C NONSCANNER RECORDS. C NSCEND(29)--------ENDING POSITIONS OF THE DATA ITEMS IN THE C NONSCANNER RECORDS. C ISCBEG(49)--------BEGINNING POSITIONS OF THE DATA ITEMS IN THE C SCANNER RECORDS. C ISCEND(49)--------ENDING POSITIONS OF THE DATA ITEMS IN THE C SCANNER RECORDS. C ISCMAX(7)---------MAXIMUM POSSIBLE NUMBER OF DATA RECORDS (OR C REGIONS) IN EACH OF THE SCANNER DATA FILES. C INSMAX(16)--------MAXIMUM POSSIBLE NUMBER OF DATA RECORDS (OR C REGIONS IN EACH OF THE NONSCANNER DATA FILES. C ISCNDX(49)--------CONTAINS THE NUMBER(S) OF THE SCANNER DTA C ITEMS TO BE ACCESSED. THESE NUMBERS ARE C OBTAINED BY LOOKING AT THE DATA STATEMENTS C FOR THE ARRAY SCNNAM AND CHOOSING THE C APPROPRIATE SUBSCRIPTS. C NSINDX(29)-------CONTAINS THE NUMBER(S) OF THE NONSCANNER DATA C ITEMS TO BE ACCESSED. THESE NUMBERS ARE C OBTAINED BY LOOKING AT THE DATA STATEMENTS C FOR THE ARRAY NSCNAM AND CHOOSING THE C APPROPRIATE SUBSCRIPTS. C ISCITM-----------VARIABLE WHICH IS SET TO THE NUMBER OF C ITEMS TO BE ACCESSED IN THE SCANNER RECORDS C DURING A GIVEN RUN. C INSITM-----------VARIABLE WHICH IS SET TO THE NUMBER OF C ITEMS TO BE ACCESSED IN THE NONSCANNER RECORDS C DURING A GIVEN RUN. C C /DATRAY/ C C ISCPCK(1290)----------ARRAY CONTAINING THE PACKED SCANNER RECORDS C AND SCALE FACTORS. C ISCFAC(675)----------ARRAY CONTAINING THE UNPACKED SCANNER SCALE C FACTORS. C INSPCK(720)-----------INPUT ARRAY CONTAINING THE PACKED NONSCANNER C RECORDS AND SCALE FACTORS. C INSFAC(360)----------ARRAY CONTAINING THE UNPACKED NONSCANNER C SCALE FACTORS. C ISCDAT(675)----------INTERMEDIATE ARRAY CONTAINING THE UNPACKED C BUT UNSCALED SCANNER DATA VALUES. C RSCDAT(675)----------ARRAY CONTAINING THE UNPACKED AND SCALED C DATA VALUES. C INSDAT(360)----------INTERMEDIATE ARRAY CONTAINING THE UNPACKED C BUT UNSCALED NONSCANNER DATA VALUES. C RNSDAT(360)----------ARRAY CONTAINING THE UNPACKED AND SCALED C NONSCANNER DATA VALUES. C C /DESCRP/ C C SCNNAM(49)--------CHARACTER STRINGS DESCRIBING THE DATA ITEMS IN C THE SCANNER FILES. C NSCNAM(29)--------CHARACTER STRINGS DESCRIBING THE DATA ITEMS IN C THE NONSCANNER FILES. C C /FILLOC/ C C ISCFIL(7)----------ARRAY WITH EACH ELEMENT REPRESENTING ONE C OF THE SCANNER FILES. THESE ELEMENTS ARE C SET TO ONE IF IT IS DESIRED TO ACCESS THE C FILE OR TO 0 OTHERWISE. C INSFIL(16)---------ARRAY WITH EACH ELEMENT REPRESENTING ONE C OF THE NONSCANNER FILES. THESE ELEMENTS C ARE SET TO ONE IF IT IS DESIRED TO ACCESS C THE FILE OR TO 0 OTHERWISE. C C /FILVAL/ C C DFALT(3)------------ARRAY CONTAINING FILL/DEFAULT VALUES FOR C PACKED DATA. C 32 BITS = 2147483647.0 C 16 BITS = 32767.0 ** C 8 BITS = 127.0 C C ** ONE NOW BEING USED DUE TO CHANGE TO USING ERBE UTILITIES C C /RECLOC/ C C ISCREC(7)----------EACH ELEMENT IN THE ARRAY IS SET TO THE FIRST C PHYSICAL RECORD TO BE ACCESSED IN THAT FILE. C NOTE THAT THE REGION NUMBERS DO NOT C NECESSARILY CORRESPOND TO THE RECORD NUMBER C SINCE SOME REGIONS MAY BE MISSING. C INSREC(16)---------SAME AS FOR ISCREC BUT FOR THE NONSCANNER C RECORDS. C LSCREC(7)----------EACH ELEMENT IN THE ARRAY IS SET TO THE LAST C PHYSICAL RECORD TO BE ACCESSED IN THAT C FILE. AGAIN, PHYSICAL RECORD NUMBERS DO C NOT NECESSARILY CORRESPOND TO REGION NUMBER. C LNSREC(16)---------SAME AS FOR LSCREC BUT FOR THE NONSCANNER C RECORDS. C C /S4IO/ C C IOS4--------------INPUT FILE. C NFILE-------------OUTPUT FILE CONTAINING UNFORMATTED OUTPUT. C NPKS4-------------OUTPUT FILE CONTAINING FORMATTED OUTPUT. C IERR--------------ERROR INDICATOR. LOGICAL SET TO TRUE OR FALSE. C DOREP-------------PROGRAM PRODUCES A FORMATTED LISTING OF THE C PROCESSED RECORDS WHEN DOREP SET TO TRUE. C DOFILE------------PROGRAM PRODUCES AN UNFORMATTED LISTING OF C PROCESSED DATA RECORDS WHEN DOFILE SET TO C TRUE. C C /UNPDAT/ C C IBITNO(3)---------THE DATA WAS PACKED USING 32-BIT, 16-BIT, AND C 8-BIT WORDS. THIS ARRAY IS USED IN UNPACKING C THE DATA. C ISTPOS(3,2)-------INDICATES THE LOCATIONS OF THE FIRST WORD C FOR THE 32-BIT, 16-BIT, C AND 8-BIT WORDS FOR EACH OF THE TWO BASIC C TYPES OF DATA FILES. C 1. SCANNER C 2. NONSCANNER C LSTPOS(3,2)-------INDICATES THE LOCATIONS OF THE LAST WORDS FOR C 32-BIT, 16-BIT, 8-BIT WORDS FOR EACH OF C THE TWO BASIC TYPES OF DATA FILES: C 1. SCANNER C 2. NONSCANNER C NUMBTYP-----------THE NUMBER OF X-BIT WORD TYPES. FOR S-4 C THERE ARE THREE: 32-BIT, 16-BIT, AND 8-BIT C WORDS. C C CHARACTER SCNNAM*37, NSCNAM*32 LOGICAL IERR,DOREP,DOFILE C COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /UNPDAT/IBITNO(3),ISTPOS(3,2),LSTPOS(3,2),NUMBTYP COMMON /DATLOC/ NSCBEG(29),NSCEND(29),ISCBEG(49),ISCEND(49), 2 ISCMAX(7), INSMAX(16), ISCNDX(49), NSINDX(29), 3 ISCITM, INSITM COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /GLOBAL/ ISUBNO,IVERSN,MSGUNT,IVAR(3),RVAR(3) COMMON /HEADER/ IYR,IMO,ISPACE,INSTCD COMMON /RECLOC/ ISCREC(7), LSCREC(7), 1 INSREC(16), LNSREC(16) COMMON /FILLOC/ ISCFIL(7), INSFIL(16) COMMON /FILVAL/ DFALT(3) COMMON /DESCRP/ SCNNAM(49), NSCNAM(29) C CCCCC DATA STATEMENTS C CCCCCCCCCCCCCCCCCCC START OF DYNAMIC ITEMS CCCCCCCCCCCCCCCCCCCCCCCCCC C CCC IF BOTH LOGICAL VARIABLES BELOW ARE SET TO TRUE, TWO CCC SEPARATE FILES WILL BE CREATED. DOREP CAUSES A CCC FORMATTED FILE (LABELLED VALUES ARE PRINTED OUT IN CCC THE SAME ORDER AS THEY ARE STORED IN THE RECORDS). CCC DOFILE CAUSES AN UNFORMATTED FILE (VALUES ARE PRINTED CCC WITHOUT LABELS IN ONE LARGE GROUP). ALL THE ABOVE CCC VALUES HAVE BEEN UNPACKED AND SCALED. CCC DOFILE WILL PRINT OUT ALL VALUES IN A GIVEN RECORD WHILE CCC DOREP WILL PRINT OUT ONLY THOSE VALUES SELECTED BELOW. C DATA DOREP /.TRUE./ C DATA DOFILE /.FALSE./ C CCCC DETERMINE WHICH FILES TO ACCESS BY SETTING THE APPROPRIATE CCCC VALUES TO 1 AND THE REMAINDER TO 0. THE ARRAY ISCFIL REPRESENTS CCCC THE SCANNER FILES AND THE ARRAY INSFIL REPRESENTS THE NONSCANNER CCCC FILES. C DATA ISCFIL / 0, 0, 0, 0, 0, 0, 0/ DATA INSFIL / 0, 0, 0, 0, 0, 2 0, 0, 0, 0, 0, 3 0, 0, 0, 4 0, 0, 0 / C CCC DETERMINE THE FIRST AND LAST RECORDS CCC IN THE DESIRED RANGE FOR EACH FILE CHOSEN. ARRAY ISCREC CCC CONTAINS THE FIRST RECORD NUMBERS FOR THE SCANNER RECORDS AND CCC ARRAY LSCREC CONTAINS THE LAST RECORD NUMBERS FOR THE SCANNER CCC RECORDS. ARRAY INSREC CONTAINS THE FIRST RECORD NUMBERS FOR CCC THE NONSCANNER RECORDS AND ARRAY LNSREC CONTAINS THE LAST CCC RECORD NUMBERS FOR THE NONSCANNER FILES. C DATA ISUBNO/7/, IVERSN/3/ DATA IYR, IMO, ISPACE,INSTCD /0,0,1,3/ DATA ISCREC /0,0,0,0,0,0,0 / DATA LSCREC /0, 0, 0, 0, 0, 0, 0 / DATA INSREC / 0,0,0,0,0, 2 0,0,0,0,0, 3 0,0,0, 4 0,0,0 / DATA LNSREC / 0, 0, 0, 0, 0, 1 0, 0, 0, 0, 0, 3 0, 0, 0, 4 0, 0, 0 / C CCC NOTE: THE PHYSICAL RECORD NUMBERS AND THE REGION NUMBERS WILL CCC NOT CORRESPOND WHEN THERE ARE MISSING REGIONS IN THE DATA. CCC SEE THE REGIONAL REPORTS TO DETERMINE THE CORRESPONDENCE CCC BETWEEN REGION NUMBER AND RECORD NUMBER. C CCC DETERMINE WHICH DATA ITEMS ARE TO BE ACCESSED. SEE THE DATA CCC STATEMENTS BELOW FOR DESCRIPTIONS OF THE DATA ITEMS. ENTER CCC THE CORRESPONDING SUBSCRIPT NUMBERS IN THE ARRAY BELOW. USE THE CCC SUBSCRIPT NUMBERS FROM THE SCNNAM ARRAY IN THE ISCNDX ARRAY CCC FOR SCANNER DATA ITEMS. USE THE SUBSCRIPT NUMBERS FROM THE CCC NSCNAM ARRAY IN THE NSINDX ARRAY FOR THE NONSCANNER DATA CCC ITEMS. C DATA ISCNDX /49*0/ DATA NSINDX /29*0/ C CCC INDICATE THE TOTAL NUMBER OF ITEMS TO BE ACCESSED CCC HERE FOR SCANNER AND/OR NONSCANNER. CCC SET ISCITM TO 49 IF ALL THE SCANNER ITEMS ARE TO BE CCC ACCESSED. SET INSITM TO 28 IF ALL THE NONSCANNER ITEMS CCC ARE TO BE ACCESSED. C DATA ISCITM /0/ DATA INSITM /0/ C CCCCCCCCCCCCCC END OF DYNAMIC ITEMS CCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C CCC THE ITEMS BELOW ARE CONSTANTS AND SHOULD NOT BE CHANGED. C DATA ISCMAX /10082, 2592, 648, 72, 36, 18, 3 / DATA INSMAX /2592, 648, 36, 18, 2, 1 2592, 648, 36, 18, 2, 2 648, 18, 1, 3 648, 18, 1 / DATA IBITNO /32, 16, 8/ DATA ISTPOS /1,91,436, 1 1,61,241/ DATA LSTPOS /90,435,675, 1 60,240,360/ DATA NUMBTYP / 3 / DATA SCNNAM(1)/ 'FILE ID '/ DATA SCNNAM(2) /'TSOLRD-MONTHLY(DAY) '/ DATA SCNNAM(3) /'NET-MONTHLY(DAY) '/ DATA SCNNAM(4) /'NETCS-MONTHLY(DAY) '/ DATA SCNNAM(5) /'TSOLRDCS-MONTHLY(DAY) '/ DATA SCNNAM(6) /'NET-MONTHLY(HR) '/ DATA SCNNAM(7) /'TSOLRH-MONTHLY(HR) '/ DATA SCNNAM(8) /'NETCS-MONTHLY(HR) '/ DATA SCNNAM(9) /'TSOLRHCS-MONTHLY(HR) '/ DATA SCNNAM(10)/'SOLARD-DAILY '/ DATA SCNNAM(11)/'SOLARH-MONTHLY HOURLY '/ DATA SCNNAM(12)/'SOLARHCS-MONTHLY HOURLY '/ DATA SCNNAM(13)/'SPARES '/ DATA SCNNAM(14) /'REGION NUMBER '/ DATA SCNNAM(15) /'DATE: YYMM '/ DATA SCNNAM(16) /'SPACECRAFT ID '/ DATA SCNNAM(17) /'LW-MONTHLY(DAY) '/ DATA SCNNAM(18) /'SW-MONTHLY(DAY) '/ DATA SCNNAM(19) /'ALBEDO-MONTHLY(DAY) '/ DATA SCNNAM(20) /'LWCS-MONTHLY(DAY) '/ DATA SCNNAM(21) /'SWCS-MONTHLY(DAY) '/ DATA SCNNAM(22) /'ALBEDOCS-MONTHLY(DAY) '/ DATA SCNNAM(23) /'LW-MONTHLY(HOUR) '/ DATA SCNNAM(24) /'SW-MONTHLY(HOUR) '/ DATA SCNNAM(25) /'ALBEDO-MONTHLY(HOUR) '/ DATA SCNNAM(26) /'LWCS-MONTHLY(HOUR) '/ DATA SCNNAM(27) /'SWCS-MONTHLY(HOUR) '/ DATA SCNNAM(28) /'ALBEDOCS-MONTHLY(HOUR) '/ DATA SCNNAM(29) /'LW-DAILY '/ DATA SCNNAM(30) /'SW-DAILY '/ DATA SCNNAM(31) /'ALBEDO-DAILY '/ DATA SCNNAM(32) /'LWCS-DAILY '/ DATA SCNNAM(33) /'SWCS-DAILY '/ DATA SCNNAM(34) /'ALBEDOCS-DAILY '/ DATA SCNNAM(35) /'LW-MONTHLY HOURLY '/ DATA SCNNAM(36) /'SW-MONTHLY HOURLY '/ DATA SCNNAM(37) /'ALBEDO-MONTHLY HOURLY '/ DATA SCNNAM(38) /'LWCS-MONTHLY HOURLY '/ DATA SCNNAM(39) /'SWCS-MONTHLY HOURLY '/ DATA SCNNAM(40) /'ALBEDOCS-MONTHLY HOURLY '/ DATA SCNNAM(41) /'NDLW-DAILY '/ DATA SCNNAM(42) /'NDSW-DAILY '/ DATA SCNNAM(43) /'NDLWCS-DAILY '/ DATA SCNNAM(44) /'NDSWCS-DAILY '/ DATA SCNNAM(45) /'NHLW-MONTHLY HOURLY '/ DATA SCNNAM(46) /'NHSW-MONTHLY HOURLY '/ DATA SCNNAM(47) /'NHLWCS-MONTHLY HOURLY '/ DATA SCNNAM(48) /'NHSWCS-MONTHLY HOURLY '/ DATA SCNNAM(49) /'SCANNER GEOGRAPHIC SCENE TYPE '/ DATA NSCNAM(1) /'FILE ID '/ DATA NSCNAM(2) /'TSOLRD-MONTHLY(DAY) '/ DATA NSCNAM(3) /'MNET-MONTHLY(DAY) '/ DATA NSCNAM(4) /'MNET-MONTHLY(HR) '/ DATA NSCNAM(5) /'TSOLRH-MONTHLY(HR) '/ DATA NSCNAM(6) /'SOLARD-DAILY '/ DATA NSCNAM(7) /'SOLARH-MONTHLY HOURLY '/ DATA NSCNAM(8) /'REGION NUMBER '/ DATA NSCNAM(9) /'DATE: YYMM '/ DATA NSCNAM(10)/'SPACECRAFT ID '/ DATA NSCNAM(11)/'LW-MONTHLY(DAY) '/ DATA NSCNAM(12)/'SW-MONTHLY(DAY) '/ DATA NSCNAM(13)/'ALBEDO-MONTHLY(DAY) '/ DATA NSCNAM(14)/'LW-MONTHLY(HR) '/ DATA NSCNAM(15)/'SW-MONTHLY(HR) '/ DATA NSCNAM(16)/'ALBEDO-MONTHLY(HR) '/ DATA NSCNAM(17)/'LW-DAILY '/ DATA NSCNAM(18)/'SW-DAILY '/ DATA NSCNAM(19)/'ALBEDO-DAILY '/ DATA NSCNAM(20)/'LW-MONTHLY HOURLY '/ DATA NSCNAM(21)/'SW-MONTHLY HOURLY '/ DATA NSCNAM(22)/'ALBEDO-MONTHLY HOURLY '/ DATA NSCNAM(23)/'NONSCANNER GEOGRAPHIC SCENE TYPE'/ DATA NSCNAM(24)/'NDLW-DAILY '/ DATA NSCNAM(25)/'NDSW-DAILY '/ DATA NSCNAM(26)/'NHLW-MONTHLY HOURLY '/ DATA NSCNAM(27)/'NHSW-MONTHLY HOURLY '/ DATA NSCNAM(28)/'DEAD SCANNER FLAGS '/ DATA NSCNAM(29)/'SPARES '/ DATA NSCBEG /1,2,3,4,5,6,37,61,62,63,64,65,66,67,68,69, 1 70,101,132,163,187,211,235,241,272,303,327,351,354/ DATA NSCEND /1,2,3,4,5,36,60,61,62,63,64,65,66,67,68,69, 1 100,131,162,186,210,234,235,271,302,326,350,353,360/ DATA ISCBEG /1,2,3,4,5,6,7,8,9,10,41,65,89,91,92,93,94,95, 1 96,97,98,99,100,101,102,103,104,105,106, 2 137,168,199,230,261,292,316,340,364,388, 3 412,436,467,498,529,560,584,608,632,656 / DATA ISCEND /1,2,3,4,5,6,7,8,9,40,64,88,90,91,92,93,94,95, 1 96,97,98,99,100,101,102,103,104,105,136,167, 2 198,229,260,291,315,339,363,387,411,435,466, 3 497,528,559,583,607,631,655,656 / DATA IOS4, NPKS4, NFILE,IDB /8, 9,10,15/ DATA DFALT /2147483647.0, 32767.0, 127.0/ C END C C SUBROUTINE SCNINIT C C THE PURPOSE OF THIS SUBROUTINE IS TO INITIALIZE ALL ARRAYS C AND VARIABLES TO BE USED TO DUMP A SCANNER DATA RECORD C C COMMON BLOCKS: /S4IO/, /UNPDAT/, /DATLOC/, /DATRAY/, /RECLOC/, C /FILLOC/, /NMPARAM/ C C KEY LOCAL VARIABLES: C C ISCFLNO - ARRAY CONTAINING WHICH SCANNER FILE TO DUMP C ISCRAY - ARRAY CONTAINING SCANNER DATA ITEMS TO DUMP C ISCRAYC - ARRAY CONTAINING SCANNER CLEAR SKY DATA C ITEMS TO DUMP C LOGICAL IERR, DOREP, DOFILE C COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /UNPDAT/IBITNO(3),ISTPOS(3,2),LSTPOS(3,2),NUMBTYP COMMON /DATLOC/ NSCBEG(29),NSCEND(29),ISCBEG(49),ISCEND(49), 2 ISCMAX(7), INSMAX(16), ISCNDX(49), NSINDX(29), 3 ISCITM, INSITM COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /RECLOC/ ISCREC(7), LSCREC(7), 1 INSREC(16), LNSREC(16) COMMON /FILLOC/ ISCFIL(7), INSFIL(16) COMMON /NMPARAM/ INST, IRES, IMF, ICOVRG, IRECF, 2 IRECL, IRAY(4), IDATA(9) C DIMENSION ISCFLNO(3,3), ISCRAY(4,9), ISCRAYC(4,9) C DATA ISCFLNO /1, 4, 7, 2 2, 5, 7, 3 3, 6, 7 / DATA ISCRAY / 17, 23, 29, 35, 2 18, 24, 30, 36, 3 3, 6, 0, 0, 4 2, 7, 10, 11, 5 19, 25, 31, 37, 6 0, 0, 42, 0, 7 0, 0, 41, 0, 8 0, 0, 0, 46, 9 0, 0, 0, 45 / DATA ISCRAYC / 20, 26, 32, 38, 2 21, 27, 33, 39, 3 4, 8, 0, 0, 4 5, 9, 10, 12, 5 22, 28, 34, 40, 6 0, 0, 44, 0, 7 0, 0, 43, 0, 8 0, 0, 0, 48, 9 0, 0, 0, 47 / C CCCCCCCCCCCCCCCCC BEGIN SCNINIT CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C ISUB = ISCFLNO (ICOVRG,IRES) ISCFIL(ISUB) = 1 ISCNDX(1) = 1 ISCNDX(2) = 14 ISCNDX(3) = 49 C K=3 C IF ((IMF.EQ.1).OR.(IMF.EQ.3)) THEN DO 100 I=1,4 IF (IRAY(I).EQ.1) THEN DO 200 J=1,9 IF (IDATA(J).EQ.1) THEN IF (ISCRAY(I,J).NE.0) THEN K = K+1 ISCNDX (K) = ISCRAY (I,J) ENDIF ENDIF 200 CONTINUE ENDIF 100 CONTINUE ENDIF C IF ((IMF.EQ.2).OR.(IMF.EQ.3)) THEN DO 300 I=1,4 IF (IRAY(I).EQ.1) THEN DO 400 J=1,9 IF (IDATA(J).EQ.1) THEN IF (ISCRAYC(I,J).NE.0) THEN K = K+1 ISCNDX(K) = ISCRAYC(I,J) ENDIF ENDIF 400 CONTINUE ENDIF 300 CONTINUE ENDIF C ISCITM = K ISCREC (ISUB) = IRECF LSCREC (ISUB) = IRECL C RETURN END C C SUBROUTINE NSCINIT C C THE PURPOSE OF THIS SUBROUTINE IS TO INITIALIZE THE ARRAYS AND C VARIABLES USED TO DUMP NONSCANNER DATA C C COMMON BLOCKS: /DATLOC/, /S4IO/, /UNPDAT/, /DATRAY/, /RECLOC/, C /FILLOC/, /NMPARAM/ C C KEY LOCAL VARIABLES: C C INSRAY - ARRAY CONTAINING NONSCANNER DATA ITEMS TO C BE DUMPED C INFFLIM- ARRAY CONTAINING FILE NUMBERS FOR NUMERICAL C FILTER MFOV C INFFLIW- ARRAY CONTAINING FILE NUMBERS FOR NUMERICAL C FILTER WFOV C ISFFIL - ARRAY CONTAINING FILE NUMBERS FOR SHAPE FACTOR C LOGICAL IERR,DOREP, DOFILE COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /UNPDAT/IBITNO(3),ISTPOS(3,2),LSTPOS(3,2),NUMBTYP COMMON /DATLOC/ NSCBEG(29),NSCEND(29),ISCBEG(49),ISCEND(49), 2 ISCMAX(7), INSMAX(16), ISCNDX(49), NSINDX(29), 3 ISCITM, INSITM COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /RECLOC/ ISCREC(7), LSCREC(7), 1 INSREC(16), LNSREC(16) COMMON /FILLOC/ ISCFIL(7), INSFIL(16) COMMON /NMPARAM/ INST, IRES, IMF, ICOVRG, IRECF, 2 IRECL, IRAY(4), IDATA(9) C DIMENSION INSRAY(4,9) DIMENSION INFFILM(3,2), INFFILW(3,2), ISFFIL(3,2) DATA INFFILM / 1, 3, 5, 2 2, 4, 5 / DATA INFFILW / 6, 8, 10, 2 7, 9, 10 / DATA ISFFIL / 11, 12, 13, 2 14, 15, 16 / DATA INSRAY / 11, 14, 17, 20, 2 12, 15, 18, 21, 3 3, 4, 0, 0, 4 2, 5, 6, 7, 5 13, 16, 19, 22, 6 0, 0, 25, 0, 7 0, 0, 24, 0, 8 0, 0, 0, 27, 9 0, 0, 0, 26 / C CCCCCCCCCCCCCCCCC BEGIN NSCINIT CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF ((IMF.EQ.1).AND.(IRES.NE.3)) THEN ISUB = INFFILM(ICOVRG,IRES) ELSE 2 IF ((IMF.EQ.2).AND.(IRES.NE.3)) THEN ISUB = INFFILW(ICOVRG,IRES) ELSE 2 IF (IRES.EQ.3) THEN ISUB = ISFFIL(ICOVRG,IMF) ENDIF C INSFIL(ISUB) = 1 NSINDX(1) = 1 NSINDX(2) = 8 NSINDX(3) = 23 NSINDX(4) = 28 K=4 DO 100 I=1,4 IF (IRAY(I).EQ.1) THEN DO 200 J=1,9 IF (IDATA(J).EQ.1) THEN IF (INSRAY(I,J).NE.0) THEN K = K+1 NSINDX (K) = INSRAY (I,J) ENDIF ENDIF 200 CONTINUE ENDIF 100 CONTINUE C INSITM = K INSREC (ISUB) = IRECF LNSREC (ISUB) = IRECL C RETURN END C C SUBROUTINE SCNSCL (isccal) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO UNPACK AND PRINT OUT THE SCANNER SCALE FACTORS C AND MAKE THEM READY FOR USE WITH THE SCANNER DATA. C C COMMON BLOCKS: /DATRAY/, S4IO/, /FILVAL/, /UNPDAT/ C C CCCCC LOGICAL STATEMENTS C LOGICAL IERR, DOREP,DOFILE DIMENSION LOC(4), NUM(4) COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /FILVAL/ DFALT(3) COMMON /UNPDAT/IBITNO(3),ISTPOS(3,2),LSTPOS(3,2),NUMBTYP dimension itemp(1050), itemp2(240) C IOPT = 0 LOC(1) = 1 LOC(2) = 91 LOC(3) = 436 LOC(4) = 0 NUM(1) = 90 NUM(2) = 345 NUM(3) = 240 NUM(4) = 0 call cread(isccal,1050,itemp,ios) if (ios.ne.1050) go to 333 call cread(isccal,240,itemp2,ios) if (ios.ne.240) go to 333 do 10 i = 1,263 iscpck(i) = itemp (i) 10 continue k = 0 do 20 j = 264,323 k = k + 1 iscpck (j) = itemp2 (k) 20 continue CALL STUFF(DFALT(2),IOPT,ISCPCK,LOC,NUM,ISCFAC,NTOT) C CCCCC WRITE OUT SCALE FACTORS C WRITE (NPKS4,555) 555 FORMAT (' ',5X,' SCANNER SCALE FACTORS',/) WRITE (NPKS4,*) ISCFAC GOTO 999 C CCCCC ERROR MESSAGES C 222 WRITE (NPKS4,225) IOS 225 FORMAT (1X,' ATTEMPTED TO READ SCANNER SCALE FACTORS--IOS = ',I4) IERR = .TRUE. GOTO 999 C 333 WRITE (NPKS4,335) IOS 335 FORMAT (1X,' HIT END OF FILE ON SCANNER ', 1 'SCALE FACTOR READ--IOS=',I4) IERR = .TRUE. C 999 RETURN END C SUBROUTINE NSCSCL (inscal) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO UNPACK AND PRINT OUT THE NONSCANNER SCALE FACTORS C AND MAKE THEM READY FOR USE WITH THE NONSCANNER DATA. C C COMMON BLOCKS: /DATRAY/, /S4IO/, /UNPDAT/, /FILVAL/ C C CCCCC LOGICAL STATEMENTS C LOGICAL IERR, DOREP, DOFILE DIMENSION LOC(4), NUM(4) COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /UNPDAT/IBITNO(3),ISTPOS(3,2),LSTPOS(3,2),NUMBTYP COMMON /FILVAL/ DFALT(3) C CCCCC BEGIN NSCSCL PROCESSING C IOPT = 0 LOC(1) = 1 LOC(2) =61 LOC(3) =241 LOC(4) = 0 NUM(1) = 60 NUM(2) =180 NUM(3) =120 NUM(4) = 0 call cread(inscal,720,inspck,ios) if (ios.ne.720) go to 333 C CCCCC UNPACK THE SCALE FACTOR RECORD C CALL STUFF(DFALT(2),IOPT,INSPCK,LOC,NUM,INSFAC,NTOT) C CCCCC WRITE OUT SCALE FACTORS C WRITE (NPKS4,550) 550 FORMAT ('0') WRITE (NPKS4,555) 555 FORMAT (' ',5X,' NONSCANNER SCALE FACTORS ',/) WRITE (NPKS4,*) INSFAC GOTO 999 C CCCCC ERROR MESSAGES C 222 WRITE (NPKS4,225) IOS 225 FORMAT (1X,' ATTEMPTED TO READ NONSCANNER ', 1 'SCALE FACTORS--IOS = ',I4) IERR = .TRUE. GOTO 999 C 333 WRITE (NPKS4,335) IOS 335 FORMAT (1X,' HIT END OF FILE ON NONSCANNER ', 1 'SCALE FACTOR READ--IOS=',I4) IERR = .TRUE. C 999 RETURN END C C SUBROUTINE SCNFIL (IFILE ) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO PROCESS THE DESIRED RECORDS OF ANY GIVEN C SCANNER FILE. C C INPUT PARAMETERS: IFILE - FILE NUMBER TO BE DUMPED C C COMMON BLOCKS: /DATLOC/, /DATRAY/, /DESCRP/, /RECLOC/, /S4IO/ C CHARACTER SCNNAM*37, NSCNAM*32, UNXFILE*6, nxfiles(7)*6 LOGICAL IERR, IEOF, DOREP, DOFILE COMMON /DATLOC/ NSCBEG(29), NSCEND(29), ISCBEG(49), ISCEND(49), 2 ISCMAX(7), INSMAX(16), ISCNDX(49), NSINDX(29), 3 ISCITM, INSITM COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 2 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /DESCRP/ SCNNAM(49), NSCNAM(29) COMMON /RECLOC/ ISCREC(7), LSCREC(7), 2 INSREC(16), LNSREC(16) COMMON /S4IO/ IOS4,NFILE, NPKS4, IERR, DOREP, DOFILE,IDB c +++ c daac conversion - insert 7 filenames for scanner files c +++ data nxfiles/'file4','file5','file6','file7','file8', 1 'file9','file10'/ C CCCCC BEGIN SCANNER FILE PROCESSING C IEOF = .FALSE. unxfile=nxfiles(ifile) indx = 5 if (ifile .eq. 7) indx = 6 call copen(unxfile,indx,isscl) WRITE (NPKS4,1000) IFILE C CCCCC DETERMINE RANGE OF RECORDS TO BE LOOKED AT C IFREC = ISCREC (IFILE) ILREC = LSCREC (IFILE) C DO 100 ICNT = IFREC,ILREC 103 CALL SCNREC (IEOF, isscl) IF (IERR) GOTO 999 IF (IEOF) GOTO 900 IF (ILREC.LT.RSCDAT(91)) GOTO 850 IF (RSCDAT(91).LT.IFREC) GOTO 103 IF((RSCDAT(91).GE.IFREC).AND.(RSCDAT(91).LE.ILREC)) THEN IF (DOREP) THEN C WRITE (NPKS4,1100) ICNT WRITE (NPKS4,1100) DO 150 INDX = 1,ISCITM ITEM = ISCNDX(INDX) WRITE (NPKS4,1200) SCNNAM(ITEM) JBEG = ISCBEG(ITEM) JEND = ISCEND(ITEM) WRITE (NPKS4,*) (RSCDAT(I),I=JBEG,JEND) WRITE (NPKS4,*) WRITE (IDB,*) (RSCDAT(I),I=JBEG,JEND) 150 CONTINUE ENDIF ENDIF 100 CONTINUE C GOTO 999 C 333 IERR = .TRUE. WRITE (NPKS4,1300) IFILE, IOS GOTO 999 C 850 WRITE (NPKS4,1350) 900 IEOF = .FALSE. WRITE (NPKS4,1400) IFILE CLOSE (IOS4,IOSTAT=IOS,ERR=955) GOTO 999 C 955 IERR = .TRUE. WRITE (NPKS4,1500) IFILE C 999 RETURN C CCCCC FORMAT STATEMENTS C 1000 FORMAT ('1',10X,'SCANNER FILE ',I1,//) 1100 FORMAT (' ',15X,'START OF A NEW RECORD ',/) 1200 FORMAT (' ',5X,A37) 1300 FORMAT (' ',5X,'OPEN FILE ERROR ON SCANNER FILE ',I1,/, 1 5X,' IOS = ',I6,/) 1350 FORMAT(' ',5X,'**** REGION READ IS PAST REGION DESIRED ****',/) 1400 FORMAT (' ',5X,'HAVE REACHED EOF ON SCANNER FILE ',I1,/) 1500 FORMAT (' ',5X,'CLOSE ERROR ON SCANNER FILE ',I1,/) C END C C SUBROUTINE NSCFIL (IFILE ) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO PROCESS THE DESIRED RECORDS OF ANY GIVEN C NONSCANNER FILE. C C INPUT PARAMETERS: IFILE - FILE NUMBER TO DUMP C C COMMON BLOCKS: /DATLOC/, /DATRAY/, /DESCRP/, /RECLOC/, /S4IO/ C CHARACTER SCNNAM*37, NSCNAM*32, UNXFILE*6, nxfiles(16)*6 LOGICAL IERR, IEOF, DOREP, DOFILE COMMON /DATLOC/ NSCBEG(29), NSCEND(29), ISCBEG(49), ISCEND(49), 2 ISCMAX(7), INSMAX(16), ISCNDX(49), NSINDX(29), 3 ISCITM, INSITM COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 2 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) COMMON /DESCRP/ SCNNAM(49), NSCNAM(29) COMMON /RECLOC/ ISCREC(7), LSCREC(7), 2 INSREC(16), LNSREC(16) COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB c +++ c daac conversion - insert 7 filenames for scanner files c +++ data nxfiles/'file11','file12','file13','file14','file15', 1 'file16','file17','file18','file19','file20', 2 'file21','file22','file23','file24','file25', 3 'file26'/ C CCCCC BEGIN NONSCANNER FILE PROCESSING C IEOF = .FALSE. unxfile = nxfiles(ifile) call copen(unxfile,6,inscl) c NFILE = IFILE + 7 NFILE = IFILE + 10 WRITE (NPKS4,1000) IFILE, NFILE C CCCCC DETERMINE RANGE OF RECORDS TO BE LOOKED AT C IFREC = INSREC (ifile) ILREC = LNSREC (ifile) C DO 100 ICNT = IFREC,ILREC 103 CALL NSCREC (IEOF,inscl) IF (IERR) GOTO 999 IF (IEOF) GOTO 900 IF (ILREC.LT.RNSDAT(61)) GOTO 850 IF (RNSDAT(61).LT.IFREC) GOTO 103 IF((RNSDAT(61).GE.IFREC).AND.(RNSDAT(61).LE.ILREC)) THEN WRITE(NPKS4,105) RNSDAT(62),RNSDAT(63) 105 FORMAT ('DATA DATE= ',F5.0,'SATELLITE= ',F2.0) DO 150 INDX = 1,INSITM ITEM = NSINDX(INDX) WRITE (NPKS4,1200) NSCNAM(ITEM) JBEG = NSCBEG(ITEM) JEND = NSCEND(ITEM) WRITE (NPKS4,*) (RNSDAT(I),I=JBEG,JEND) WRITE (NPKS4,*) WRITE (IDB,*) (RNSDAT(I),I=JBEG,JEND) 150 CONTINUE ENDIF 100 CONTINUE C GOTO 999 C 333 IERR = .TRUE. WRITE (NPKS4,1300) IFILE, IOS GOTO 999 C 850 WRITE(NPKS4,1350) call cread(inscl,720,inspck,ios) if(ios.ne.720) go to 333 C 900 IEOF = .FALSE. WRITE (NPKS4,1400) IFILE GOTO 999 C 955 IERR = .TRUE. WRITE (NPKS4,1500) IFILE C 999 RETURN C CCCCC FORMAT STATEMENTS C 1000 FORMAT ('1',10X,'NONSCANNER FILE ',I2,'; TAPE FILE ',I2,/) 1100 FORMAT (' ',15X,'RECORD NUMBER ',I5) 1200 FORMAT (' ',20X,A37,/) 1300 FORMAT (' ',5X,'OPEN FILE ERROR ON NONSCANNER FILE ',I1,/, 1 5X,' IOS = ',I6,/) 1350 FORMAT (' ',5X,'*** REGION READ IS PAST DESIRED REGION ***',/) 1400 FORMAT (' ',5X,'HAVE REACHED EOF ON NONSCANNER FILE ',I1,/) 1500 FORMAT (' ',5X,'CLOSE ERROR ON NONSCANNER FILE ',I1,/) C END C C SUBROUTINE SCNREC (IEOF, isscl) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO UNPACK A SCANNER DATA RECORD AND SCALE THE VALUES. C C COMMON BLOCKS: /S4IO/, /FILVAL/, /UNPDAT/, /DATRAY/ C LOGICAL IERR, IEOF, DOREP, DOFILE DIMENSION LOC(4), NUM(4) COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /FILVAL/ DFALT(3) COMMON /UNPDAT/ IBITNO(3), ISTPOS(3,2),LSTPOS(3,2),NUMBTYP COMMON /DATRAY/ ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) dimension itemp (1050), itemp2 (240) C CCCCC BEGIN SCNREC PROCESSING C IOPT = 0 LOC(1) = 1 LOC(2) = 91 LOC(3) = 436 LOC(4) = 0 NUM(1) = 90 NUM(2) = 345 NUM(3) = 240 NUM(4) = 0 IEOF = .FALSE. c call cread (isscl, 1050, itemp,ios) if (ios.ne.1050) go to 333 call cread (isscl, 240, itemp2, ios) if (ios.ne.240) go to 333 do 10 i = 1,263 iscpck(i) = itemp (i) 10 continue k = 0 do 20 j = 264,323 k = k + 1 iscpck (j) = itemp2 (k) 20 continue CALL STUFF (DFALT(2),IOPT,ISCPCK,LOC,NUM,ISCDAT,NTOT) DO 200 I=1,675 RSCDAT(I) = FLOAT(ISCDAT(I)) 200 CONTINUE C CCCCC CALCULATE SCALED VALUES C DO 230 I=1,NUMBTYP IFST = ISTPOS(I,1) ILST = LSTPOS(I,1) DO 250 J=IFST,ILST IF (RSCDAT(J).NE.DFALT(I)) 1 RSCDAT(J) = RSCDAT(J) / FLOAT(ISCFAC(J)) 250 CONTINUE 230 CONTINUE C IF (DOFILE) THEN WRITE (NFILE,1100) WRITE (NFILE,1100) 1100 FORMAT (5X) WRITE (NFILE,*) RSCDAT ENDIF C GOTO 999 C CCCCC ERROR MESSAGES C 222 WRITE (NPKS4,225) IOS 225 FORMAT (1X,' ATTEMPTED TO READ DATA RECORD--IOS = ',I4) IERR = .TRUE. GOTO 999 C 333 WRITE (NPKS4,335) IOS 335 FORMAT (1X,' HIT END OF FILE ON DATA RECORD READ-IOS=',I4) IEOF = .TRUE. C 999 RETURN END C C SUBROUTINE NSCREC (IEOF,inscl) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PURPOSE: TO UNPACK A NONSCANNER DATA RECORD AND SCALE THE VALUES. C THE FOURTH RECORD ON THE SECOND FILE ON THE RAT. C C COMMON BLOCKS: /S4IO/, /FILVAL/, /UNPDAT/, /DATRAY/ C C LOGICAL IERR, IEOF, DOREP, DOFILE DIMENSION LOC(4), NUM(4) COMMON /S4IO/ IOS4, NFILE, NPKS4, IERR, DOREP, DOFILE, IDB COMMON /FILVAL/ DFALT(3) COMMON /UNPDAT/ IBITNO(3),ISTPOS(3,2),LSTPOS(3,2),NUMBTYP COMMON /DATRAY/ISCPCK(1290),ISCFAC(675),INSPCK(720),INSFAC(360), 1 ISCDAT(675),RSCDAT(675),INSDAT(360),RNSDAT(360) C CCCCC BEGIN NSCREC PROCESSING C IOPT = 0 LOC(1) = 1 LOC(2) = 61 LOC(3) = 241 LOC(4) = 0 NUM(1) = 60 NUM(2) = 180 NUM(3) = 120 NUM(4) = 0 IEFLAG = 0 IEOF = .FALSE. 130 call cread(inscl,720,inspck,ios) if (ios.ne.720) then go to 333 endif CALL STUFF(DFALT(2),IOPT,INSPCK,LOC,NUM,INSDAT,NTOT) C DO 200 I=1,360 RNSDAT(I) = FLOAT(INSDAT(I)) 200 CONTINUE C CCCCC CALCULATE SCALED VALUES C DO 230 I=1,NUMBTYP IFST = ISTPOS(I,2) ILST = LSTPOS(I,2) DO 250 J=IFST,ILST IF (RNSDAT(J).NE.DFALT(I)) 1 RNSDAT(J) = RNSDAT(J) / FLOAT(INSFAC(J)) 250 CONTINUE 230 CONTINUE IF (DOFILE) THEN WRITE (NFILE,1100) WRITE (NFILE,1100) 1100 FORMAT (5X) WRITE (NFILE,*) RNSDAT ENDIF C GOTO 999 C CCCCC ERROR MESSAGES C 222 WRITE (NPKS4,225) IOS 225 FORMAT (1X,' ATTEMPTED TO READ DATA RECORD--IOS = ',I4) IERR = .TRUE. GOTO 999 C 333 IF (IEFLAG.EQ.0) THEN IEFLAG = 1 IEOF = .FALSE. GOTO 130 ELSE WRITE (NPKS4,335) IOS 335 FORMAT (1X,' HIT END OF FILE ON DATA RECORD READ-IOS=',I4) IEOF = .TRUE. ENDIF C 999 RETURN END C C SUBROUTINE STUFF I (DFAULT,IOPT,IDATA,LOC,NUM, O LDATA,NTOT) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NAME - STUFF MODULE -G.E.8.6.16 C LANGUAGE - FTN V TYPE - SUBROUTINE C VERSION - 3.0 DATE - 03/14/83 PROGRAMMER - ED HOWERTON C C PURPOSE - TO PACK OR UNPACK AN INTEGER ARRAY INTO AN OUTPUT INTEGER C ARRAY ACCORDING TO USER-SPECIFIED WORD SIZES (ANY COMBO C OF 32-, 16-, 8-, AND/OR 4-BIT WORDS) AND CONVERT BETWEEN C SUBSYSTEM-DEFINED DEFAULT VALUES AND WORD-SIZE-DEPENDENT C (2**(N-1)-1, WHERE N=NUMBER OF BITS PER WORD) DEFAULTS. C C INPUT PARAMETERS - C DFAULT SUBSYSTEM-DEFINED DEFAULT VALUE (REAL). C C PACKING OPERATION + UNPACKING OPERATION C ----------------- + ------------------- C IOPT =1 + =0 C + C IDATA ARRAY OF DATA VALUES TO BE + ARRAY OF INTEGERS TO BE C PACKED(INTEGER). + UNPACKED. C + C LOC 4-ELEMENT INTEGER ARRAY + 4-ELEMENT INTEGER ARRAY C CONTAINING THE START LO- + CONTAINING THE START LO- C CATIONS IN IDATA OF + CATIONS IN LDATA WHERE C VALUES TO BE PACKED AT + THE UNPACKED WORDS OF THE C THE FOLLOWING RATES: + FOLLOWING SIZES WILL BE C + STORED: C LOC(1) 32 BITS/WORD. + LOC(1) 32-BIT WORDS. C LOC(2) 16 BITS/WORD. + LOC(2) 16-BIT WORDS. C LOC(3) 8 BITS/WORD. + LOC(3) 8-BIT WORDS. C LOC(4) 4 BITS/WORD. + LOC(4) 4-BIT WORDS. C + C NUM 4-ELEMENT INTEGER ARRAY + 4-ELEMENT INTEGER ARRAY C CONTAINING THE NO. OF + CONTAINING THE NO. OF C VALUES IN IDATA TO BE + WORDS OF THE FOLLOWING C PACKED AT THE FOLLOWING + SIZES TO BE UNPACKED: C RATES: + C NUM(1) 32 BITS/WORD. + NUM(1) 32-BIT WORDS. C NUM(2) 16 BITS/WORD. + NUM(2) 16-BIT WORDS. C NUM(3) 8 BITS/WORD. + NUM(3) 8-BIT WORDS. C NUM(4) 4 BITS/WORD. + NUM(4) 4-BIT WORDS. C C NOTE: IF A WORD-SIZE IS NOT USED, SET THE APPROPRIATE C ELEMENT IN NUM=0. C C OUTPUT PARAMETERS - C LDATA INTEGER ARRAY CONTAINING THE OUTPUT FROM THE PACKING OR C UNPACKING OPERATION. C NTOT NUMBER OF 60-BIT WORDS IN LDATA USED IN THE PACKING OR C UNPACKING OPERATION (WILL BE NEGATIVE IF AN INTERNAL C CONSISTENCY CHECK WITH SPREAD/SESPRD FAILS). C C KEY LOCAL PARAMETERS - C ISTRT POINTER INDICATING WHERE IN THE PACKED ARRAY TO EITHER C START INSERTING (PACKING) OR EXTRACTING (UNPACKING) C DATA. C IRETCK TOTALS THE NO.OF 60-BIT WORDS USED BY SPREAD/SESPRD. C C SUBROUTINES CALLED - C ERBE SUBROUTINE - ONETWO (G.E.8.6.11) C ERBE SUBROUTINE - SPREAD (G.E.8.6.4) C ERBE SUBROUTINE - SESPRD (G.E.8.6.5) C C EXIT STATES - C NORMAL RETURN (NTOT MAY BE NEGATIVE, INDICATING AN ERROR). C C RESTRICTIONS - C (1) ASSUMES THAT CONTIGUOUS LOCATIONS OF LDATA WILL BE PACKED OR C THAT CONTIGUOUS LOCATIONS OF IDATA WILL BE UNPACKED. C (2) ON A PACKING OPERATION, THE USER MUST BE SURE THAT VALUES C IN THE INPUT ARRAY IDATA DO NOT OVERFLOW THE INTENDED C WORD SIZE. I.E.,(EXCEPT FOR DEFAULTS) THE RANGES C (OVERFLOW/UNDERFLOW) ARE AS FOLLOWS (SIGNED INTEGERS): C 32-BIT < IABS( 2147483648 ) C 16-BIT < IABS( 32768 ) C 8-BIT < IABS( 128 ) C 4-BIT < IABS( 8 ) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C***** PARAMETER ( IANAL = 0 ) DIMENSION IDATA(*),LOC(4),NUM(4),LDATA(*) C C *** INITIALIZE C IDFALT=NINT(DFAULT) IEXP=6 ISTRT=1 IRETCK=0 NTOT=0 C C *** LOOP THRU FOUR WORD-SIZES C DO 100 I=1,4 C NWORDS=0 IRET=0 C C ** CHECK FOR USAGE OF THIS WORD-SIZE -- IF SO, CONTINUE; IF NOT, C INCREMENT LOOP. IF(NUM(I).GT.0)THEN C C ** CALCULATE WORD-SIZE (ITWO), AND NUMBER OF 60-BIT WORDS C NEEDED FOR THE PACK OR UNPACK (NWORDS). C ITWO=2**(IEXP-I) NBITS=NUM(I)*ITWO NWORDS=NBITS/32 NPAD=NBITS-NWORDS*32 IF(NPAD.GT.0)THEN NWORDS=NWORDS+1 ENDIF K=LOC(I) C C ** CALCULATE WORD-SIZE-DEPENDENT DEFAULT (ITEST). C ITEST=2**(ITWO-1)-1 IF(IOPT.EQ.1)THEN NTOT=NTOT+NWORDS C C ** CONVERT DEFAULTS (EXCEPT 4-BIT) C IF(I.LT.4)THEN JSTOP=K+NUM(I)-1 DO 40 J=K,JSTOP IF(IDATA(J).EQ.IDFALT)THEN IDATA(J)=ITEST ENDIF 40 CONTINUE ENDIF CALL SPREAD(IDATA(K),LDATA(ISTRT),32,ITWO,NUM(I),IRET) ELSE NTOT=NTOT+NUM(I) CALL SESPRD(IDATA(ISTRT),LDATA(K),ITWO,32,NWORDS,IRET) IF(I.LT.4)THEN JSTOP=K+NUM(I)-1 DO 60 J=K,JSTOP IF(LDATA(J).EQ.ITEST)THEN LDATA(J)=IDFALT ENDIF 60 CONTINUE ENDIF ENDIF C C ** INCREMENT ISTRT AND IRETCK C ISTRT=ISTRT+NWORDS IRETCK=IRETCK+IRET ENDIF 100 CONTINUE C C ** CHECK NO.OF 60-BIT WORDS USED AS RETURNED BY SPREAD/SESPRD VS. C NO. CALCULATED BY STUFF. C IF(NTOT.NE.IRETCK)THEN NTOT=-NTOT ENDIF C RETURN END C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC c IDENT SPREAD c ENTRY SPREAD c SPREAD DATA 0 c c NAME - SPREAD MODULE - G.E.8.6.4 c LANGUAGE - COMPASS TYPE - SUBROUTINE c VERSION - 3.0 DATE - 05/27/82 PROGRAMMER - c SAMUEL A. MCPHERSON c ACD/CMB/COS c--------------------------------------------------------------------- c Version - ??? Date - 9 Oct 92 Programmer - Scott R. Quier (SAIC) c--------------------------------------------------------------------- c c Version -++++ Date - 10/05/92 Programmer - Scott R. Quier, SAIC c Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c PURPOSE: THIS FORTRAN (FTN) CALLABLE SUBROUTINE WAS c WRITTEN FOR NASA, LANGLEY RESEARCH CENTER c HAMPTON, VIRGINIA c COMMENTS: c THIS ROUTINE WILL TAKE DATA FROM THE INPUT ARRAY(B1) AND c RE-FORMAT THE DATA INTO THE OUT ARRAY (B2). c c B1 = FWA OF INPUT ARRAY c B2 = FWA OF OUT ARRAY c B3= NUMBER OF BITS/ITEM IN INPUT ARRAY c B4 = NUMBER OF BITS/ITEM IN OUT ARRAY c B5 = NUMBER OF WORDS IN INPUT ARRAY (B1) c B6 = NUMBER OF WORDS PLACED IN OUTPUT ARRAY(B2) c c CALL SPREAD(IN,IOUT,BITSIN,BITSOUT,INWORDS,OUTWORDS) c c IF BITSOUT > BITSIN, DATA MOVED INTO THE OUT ARRAY WILL BE c RIGHT JUSTIFIED WITH ZERO FILL TO THE LEFT. c c ON EACH CALL TO SPREAD, EITHER BITSIN OR BITSOUT MUST BE SET c TO 60. IF BITSOUT IS SET TO 60, A UNPACK OPERATION IS PERFORMED. c IF BITSIN IS SET TO 60, A PACK OPERATION IS PERFORMED. c c B6(OUTWORDS) ON RETURN WILL CONTAIN THE NUMBER OF OUT WORDS c c c B2 MUST BE DIMENSIONED BY (60/B3*NWORDS) c c SX7 A0 c SA7 SAVEA0 c SA3 A1 c SB1 X3 c SA3 A3+1 c SB2 X3 c SA3 A3+1 c SB3 X3 c SA3 A3+1 c SB4 X3 c SA3 A3+1 c SB5 X3 c SA3 A3+1 c SB6 X3 c SA5 B6 c SX6 A5 c SA6 SAVADD c SA1 B1-1 IN ARRAY - 1 c SA2 B2-1 OUT ARRAY - 1 c SX6 A2 c SA6 SAVOUT c SA3 B3 c SB3 X3 NUMBER OF BITS IN IN c SA4 B4 c SB4 X4 NUMBER OF BITS IN OUT c SA5 B5 NUMBER OF WORDS c SB5 X5 c MX3 1 c SB1 B3-1 c AX3 B1,X3 IN MASK c SB2 60 c MX7 0 c GE B3,B4,PACKIT cNEXT SA1 A1+1 c SB5 B5-1 c NG B5,EXIT c SB1 60 cPACK GE B2,B4,CONT c SA2 A2+1 c SA7 A2 c SB2 60 c MX7 0 ZERO OUT WORD c LT B1,B3,CONTX cCONT BX6 X1*X3 c SB6 B4-B3 c LX7 B6,X7 c BX7 X7+X6 c LX7 B3,X7 c LX1 B3,X1 c SB1 B1-B3 REMAINING IN BITS c SB2 B2-B4 REMAINING OUT c GE B1,B3,PACK c ZR B1,NEXT c GE B2,B4,CONTX c SA2 A2+1 c SA7 A2 c SB2 60 c MX7 0 cCONTX MX0 1 c SB6 B1-1 c AX0 B6,X0 c BX6 X1*X0 PICK UP REMAINING IN WORD c LX6 B3,X6 c SA1 A1+1 c SB5 B5-1 c NG B5,EXIT1 c SB6 B3-B1 c MX0 1 c SB7 B6-1 c AX0 B7,X0 PICK UP FIRST OF NEXT WORD c BX5 X1*X0 c SB1 B3-B1 c LX5 B1,X5 c BX6 X5+X6 c LX7 B4,X7 c BX7 X7+X6 c LX1 B6,X1 c SB1 B6 c SB6 60 c SB1 B6-B1 c SB2 B2-B4 c EQ PACK cPACKIT MX3 1 c SB1 B4-1 c AX3 B1,X3 c LX3 B4 MASK FOR IN c SB2 60 cLOOP1 SA1 A1+1 c SB5 B5-1 DECREMENT # OF IN WORDS c NG B5,ENDIT c BX6 X1*X3 MASK OUT DATA c SB2 B2-B4 # BITS REMAINING IN OUT c NG B2,LOOP2 c LX7 B4 c BX7 X7+X6 ADD MASKED DATA c EQ LOOP1 cLOOP2 SB2 B2+B4 # BITS IN UPPER PART OF WORD c EQ B2,B0,STORE1 c LX7 B2,X7 c MX4 1 c SB1 B4-B2 # BITS IN LOWER PART OF DATA c SB6 B1-1 c AX4 B6,X4 c LX4 B1 c BX5 X4*X6 SAVE LOWER PART OF DATA c AX6 B1,X6 SHIFT OUT LOWER PART OF DATA c BX7 X7+X6 ADD UPPER PART TO STORE c BX6 X5 c SB7 60 c SB2 B7-B1 c EQ STORE cSTORE1 SB7 60 c SB2 B7-B4 cSTORE SA2 A2+1 c SA7 A2 c BX7 X6 c EQ LOOP1 cENDIT SB5 60 c LX7 B2 c EQ EXIT cEXIT1 BX7 X6 cEXIT SA2 A2+1 c SA7 A2 c SX1 A2 STORE RETURN NWORDS c SA3 SAVOUT c IX6 X1-X3 c SA5 SAVADD c SA4 X5 c SA6 A4 c SA5 SAVEA0 c SA0 X5 c EQ SPREAD cSAVEA0 DATA 0 cSAVADD DATA 0 cSAVOUT DATA 0 cABORT SA2 =3LABT c BX6 X2 c SA6 1 c END c----------------------------------------------------------- c This routine will take data from the input array (isrc) and c call appropriate NCAR routines (gbytes, sbytes) to re-format c the data into the output array (idest). c c Input Parameters: c c isrc : The input bit stream c inbts : Length, in bits, of the input data words c iotbts : Length, in bits, of the output data words c numpck : Number of 32-bit words in the input buffer c to be packed/unpacked c c Output Parameters: c idest : The output bit stream c numdon : Number of 32-bit words actually stuffed c into the output buffer c----------------------------------------------------------- c Subroutines Called: c gbytes : NCAR "C" routine to handle data bit wise manipulation c for the data unpacking operation. c sbytes : NCAR "C' routine to handle data bit wise manipulation c for the data packing operation c----------------------------------------------------------- c Exit States: c idest : Holds the results of the unpack/pack operation c numdon : The number of 32-bit words packed/unpacked. On c error, this will hold a zero (0) as an error flag. c----------------------------------------------------------- c Restrictions: c c - For pack operation, we can only handle (2 ** 27) - 1 c data elements at a time. c - For pack, numpck must be less than (2 ** 28) - 1. c This is driven by the way in which we calculate the c number of bytes to be processed. c----------------------------------------------------------- subroutine spread i (isrc, o idest, i inbts, iotbts, numpck, o numdon) integer isrc*4 dimension isrc(*) integer idest*4 dimension idest(*) integer inbts*4 integer iotbts*4 integer numpck*4 integer numdon*4 integer mxupck integer mxpack c c *** For pack operations, we can only handle mxupck data c *** elements. ((2 ** 27) - 1). c *** For pack operation, we can only handle mxpack data c *** elements. ((2 ** 28) - 1). c *** These constants are placed here for ease of changing the c *** code if the machine word size ever changes. c mxupck = ((2 ** 27) - 1) mxpack = ((2 ** 28) - 1) c c *** We should do all our error checking right here. It c *** sure will make the reading of the code that much easier c *** and shorten the time it takes to determine if there c *** is a problem with the incoming data. c *** By the numbers... c *** - Make sure we have something to do c *** - Make sure both word sizes are in bounds c *** - For pack operation, we can only handle (2 ** 27) - 1 c *** data elements at a time. For pack, numpck must be c *** less than (2 ** 28) - 1. This is driven by the c *** way in which we calculate the number of bytes c *** to be processed. c *** - Ensure we will be doing either an unpack or a pack c *** operation. c if(numpck .gt. 0 .and. 1 inbts .gt. 0 .and. inbts .lt. 33 .and. 2 iotbts .gt. 0 .and. iotbts .lt. 33. and. 3 ((iotbts .eq. 32 .and. numpck .lt. 134217727) .or. 4 (inbts .eq. 32 .and. numpck .lt. 268435455))) then c numdon = (numpck * iotbts) / inbts c c *** Determine if we are doing an unpack or a pack. c if(iotbts .eq. 32) then c c *** We are doing an unpack c call gbytes(isrc, idest, 0, inbts, 0, numdon) else c c *** There is potential for problem here. The data c *** going into the destination words must be of c *** small enough size to fit. Else, the user will c *** be very disappointed. c call sbytes(idest, isrc, 0, iotbts, 0, numpck) end if else c c *** For some reason, we had errors in the input parameters. c *** I guess the using application will have to figure out c *** what went wrong. c numdon = 0 end if return end SUBROUTINE SESPRD 1 (IN,IOUT,INBITS,ITBITS,INWRDS,ITWRDS) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C NAME - SESPRD MODULE - G.E.8.6.5 C LANGUAGE - FTN V TYPE - SUBROUTINE C VERSION - 3.0 DATE - 10/26/82 PROGRAMMER - C. E. HOWERTON c----------------------------------------------------------------------- c Version - ??? Date - 10/08/92 Programmer - Scott R. Quier (SAIC) c----------------------------------------------------------------------- C C PURPOSE - TAKE BIT STRING DATA FROM THE INPUT ARRAY (IN), C DO SIGN EXTEND FOR UNPACK OPERATIONS, C AND PLACE IT IN THE OUTPUT ARRAY (IOUT). C C INPUT PARAMETERS - C IN := INPUT ARRAY FROM WHICH DATA ARE REMOVED. C INBITS := BIT LENGTH OF DATA IN THE INPUT ARRAY. C (ON PACK OPERATION, INBITS = 60) C ITBITS := BIT LENGTH OF DATA IN THE OUTPUT ARRAY. C (ON UNPACK OPERATION, ITBITS = 60) C INWRDS := NUMBER OF 60-BIT WORDS IN THE INPUT ARRAY. C DIMENSION OF THE OUTPUT ARRAY MUST BE AT C LEAST ((ITBITS * INWRDS) / INBITS) C C OUTPUT PARAMETERS - C IOUT := ARRAY TO WHICH DATA RE MOVED. C ITWRDS := NUMBER OF 60-BIT WORDS USED FROM INPUT ARRAY. C C KEY LOCAL PARAMETERS - C LBIT := LOCATION OF SIGN BIT C N := LOOP CONTROL C C ROUTINES CALLED - C SUBROUTINE SPREAD (ERBE G.E.8.6.4) C C EXIT STATES - NORMAL RETURN C C---RESTRICTIONS - ASSUMES 60-BIT WORDS. c Really assumes 32-bit words, due to the machine c word size. C C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C *** BEGIN SESPRD *** C C***** PARAMETER ( IANAL = 0 ) integer shift C C$ IF ( IANAL .EQ. 1 ) THEN c--- COMMON /UTLCNT/ NCALLS(60) C$ ENDIF C***** DIMENSION IN(*), IOUT(*) C$ IF ( IANAL .EQ. 1 ) THEN c--- NCALLS( 35 ) = NCALLS( 35 ) + 1 C$ ENDIF C C C *** USE SUBROUTINE SPREAD TO DO BIT MANIPULATION C CALL SPREAD (IN,IOUT,INBITS,ITBITS,INWRDS,ITWRDS) C C *** CHECK FOR UNPACK OPERATION C c--- IF (ITBITS .EQ. 60) THEN if (itbits .eq. 32) then C *** UNPACK OPERATION C *** DO SIGN EXTEND C c--- LBIT = 60 - INBITS LBIT = 32 - INBITS N = (ITBITS * INWRDS) / INBITS DO 100 I = 1,N cmy fix 01/29/2007 don't need to do this when not on the NOS system c IOUT(I) = SHIFT(SHIFT(IOUT(I),LBIT),-(LBIT)) c 100 CONTINUE ENDIF RETURN END integer function shift( i idata, ifactor) c********************************************************************** c Name - shift Module - c Language - FORTRAN Type - function c Version - ?? Date - 13 Oct 92 Programmer - S.R. Quier (SAIC) c c Purpose - c SHIFT(a1,a2) is a specific function that returns a shifted result. c The argument a1 is the data to be shifted. Argument a2 is the c number of binary positions a1 will be shifted and the direction c of the shift. If a2 is greater than zero, the shift will be left c circular. If a2 is less than zero, the shift will be right with c sign extension and end drop off. If a2 is zero, no shift will c be accomplished. c c Key Local Parameters - c integer icount : The number of binary positions to shift idata c integer ibit31 : The value of most-significant bit c integer loop : Just a loop counter c c c Subroutines Called - c iabs() c min0() c bit() c setbit() c lshift() c rshift() c c Exit States - c c Restrictions - c ifactor must be non-zero, in the range of -32 -> 32. If not, c then the operation will either be ignored (if ifactor .eq. 0) or c ifactor will be adjusted to either 32 or -32 (depending on sign c of incoming ifactor). c c********************************************************************** integer idata integer ifactor c integer ishift integer icount logical ibit31 logical bit integer loop c c **** Need to load the value c shift = idata c c **** Make sure the user wants us to do something c if(ifactor .ne. 0) then c c **** Adjust magnitude of shift c ifactor = isign(min0(iabs(ifactor),32), ifactor) c c **** Get the number of bit to shift the data c icount = iabs(ifactor) c c **** Determine direction of shift c if(ifactor .gt. 0) then c c **** Do the left circular shift c do 100 loop = 1, icount c c **** Save most significant bit c ibit31 = bit(31, shift) c c **** Do the shift c shift = lshift(shift, 1) c c **** Perform the end-carry of most-significant bit c **** to the least significant bit position. c call setbit(0, shift, ibit31) 100 continue else c c **** For the right arithmatic shift, with sign extension c **** and end drop off, we do not need to work black magic, c **** the Sun FORTRAN does it for us. c shift = rshift(idata, icount) end if end if return end