From JLS@liverpool.ac.uk Wed Mar 11 11:54:25 1992 Received: from danpost2.uni-c.dk by dkuug.dk via EUnet with SMTP (5.64+/8+bit/IDA-1.2.8) id AA09873; Wed, 11 Mar 92 11:54:25 +0100 Received: from vm.uni-c.dk by danpost2.uni-c.dk (5.65/1.34) id AA20506; Wed, 11 Mar 92 10:53:14 GMT Message-Id: <9203111053.AA20506@danpost2.uni-c.dk> Received: from vm.uni-c.dk by vm.uni-c.dk (IBM VM SMTP V2R1) with BSMTP id 3412; Wed, 11 Mar 92 11:54:24 DNT Received: from UKACRL.BITNET by vm.uni-c.dk (Mailer R2.07) with BSMTP id 6545; Wed, 11 Mar 92 11:54:21 DNT Received: from RL.IB by UKACRL.BITNET (Mailer R2.07) with BSMTP id 5041; Wed, 11 Mar 92 10:52:19 GMT Received: from RL.IB by UK.AC.RL.IB (Mailer R2.07) with BSMTP id 1562; Wed, 11 Mar 92 10:51:35 GMT Via: UK.AC.LIV.IBM; 11 MAR 92 10:49:49 GMT Received: from JLS@UK.AC.LIVERPOOL by MAILER(4.2.a); 11 Mar 1992 10:47:31 GM Date: Wed, 11 Mar 92 10:46:52 GMT From: Lawrie Schonfelder Subject: string module B To: SC22/WG5 members X-Charset: ASCII X-Char-Esc: 29 ELSEIF( la > lb )THEN IF( string_a(lb+1:la) > blank )THEN c_gt_s = .TRUE.; RETURN ELSEIF( string_a(lb+1:la) < blank )THEN c_gt_s = .FALSE.; RETURN ENDIF ENDIF c_gt_s = .FALSE. ENDFUNCTION c_gt_s !----- LLT procedures -------------------------------------------------------! FUNCTION s_llt_s(string_a,string_b) ! string_a lb )THEN DO i = lb+1,la IF( LLT(string_a%chars(i),blank) )THEN s_llt_s = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),blank) )THEN s_llt_s = .FALSE.; RETURN ENDIF ENDDO ENDIF s_llt_s = .FALSE. ENDFUNCTION s_llt_s FUNCTION s_llt_c(string_a,string_b) type(VARYING_STRING),INTENT(IN) :: string_a CHARACTER(LEN=*),INTENT(IN) :: string_b LOGICAL :: s_llt_c INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LLT(string_a%chars(i),string_b(i:i)) )THEN s_llt_c = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),string_b(i:i)) )THEN s_llt_c = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN IF( LLT(blank,string_b(la+1:lb)) )THEN s_llt_c = .TRUE.; RETURN ELSEIF( LGT(blank,string_b(la+1:lb)) )THEN s_llt_c = .FALSE.; RETURN ENDIF ELSEIF( la > lb )THEN DO i = lb+1,la IF( LLT(string_a%chars(i),blank) )THEN s_llt_c = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),blank) )THEN s_llt_c = .FALSE.; RETURN ENDIF ENDDO ENDIF s_llt_c = .FALSE. ENDFUNCTION s_llt_c FUNCTION c_llt_s(string_a,string_b) ! string_a,string_b ISO-646 ordering CHARACTER(LEN=*),INTENT(IN) :: string_a type(VARYING_STRING),INTENT(IN) :: string_b LOGICAL :: c_llt_s INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LLT(string_a(i:i),string_b%chars(i)) )THEN c_llt_s = .TRUE.; RETURN ELSEIF( LGT(string_a(i:i),string_b%chars(i)) )THEN c_llt_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LLT(blank,string_b%chars(i)) )THEN c_llt_s = .TRUE.; RETURN ELSEIF( LGT(blank,string_b%chars(i)) )THEN c_llt_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN IF( LLT(string_a(lb+1:la),blank) )THEN c_llt_s = .TRUE.; RETURN ELSEIF( LGT(string_a(lb+1:la),blank) )THEN c_llt_s = .FALSE.; RETURN ENDIF ENDIF c_llt_s = .FALSE. ENDFUNCTION c_llt_s !----- LLE procedures -------------------------------------------------------! FUNCTION s_lle_s(string_a,string_b) ! string_a<=string_b ISO-646 ordering type(VARYING_STRING),INTENT(IN) :: string_a,string_b LOGICAL :: s_lle_s ! Returns TRUE if strings are equal or if string_a preceeds string_b in the ! ISO 646 collating sequence. Otherwise the result is FALSE. INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LLT(string_a%chars(i),string_b%chars(i)) )THEN s_lle_s = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),string_b%chars(i)) )THEN s_lle_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LLT(blank,string_b%chars(i)) )THEN s_lle_s = .TRUE.; RETURN ELSEIF( LGT(blank,string_b%chars(i)) )THEN s_lle_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN DO i = lb+1,la IF( LLT(string_a%chars(i),blank) )THEN s_lle_s = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),blank) )THEN s_lle_s = .FALSE.; RETURN ENDIF ENDDO ENDIF s_lle_s = .TRUE. ENDFUNCTION s_lle_s FUNCTION s_lle_c(string_a,string_b) ! strung_a<=string_b ISO-646 ordering type(VARYING_STRING),INTENT(IN) :: string_a CHARACTER(LEN=*),INTENT(IN) :: string_b LOGICAL :: s_lle_c INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LLT(string_a%chars(i),string_b(i:i)) )THEN s_lle_c = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),string_b(i:i)) )THEN s_lle_c = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN IF( LLT(blank,string_b(la+1:lb)) )THEN s_lle_c = .TRUE.; RETURN ELSEIF( LGT(blank,string_b(la+1:lb)) )THEN s_lle_c = .FALSE.; RETURN ENDIF ELSEIF( la > lb )THEN DO i = lb+1,la IF( LLT(string_a%chars(i),blank) )THEN s_lle_c = .TRUE.; RETURN ELSEIF( LGT(string_a%chars(i),blank) )THEN s_lle_c = .FALSE.; RETURN ENDIF ENDDO ENDIF s_lle_c = .TRUE. ENDFUNCTION s_lle_c FUNCTION c_lle_s(string_a,string_b) ! string_a<=string_b ISO-646 ordering CHARACTER(LEN=*),INTENT(IN) :: string_a type(VARYING_STRING),INTENT(IN) :: string_b LOGICAL :: c_lle_s INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LLT(string_a(i:i),string_b%chars(i)) )THEN c_lle_s = .TRUE.; RETURN ELSEIF( LGT(string_a(i:i),string_b%chars(i)) )THEN c_lle_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LLT(blank,string_b%chars(i)) )THEN c_lle_s = .TRUE.; RETURN ELSEIF( LGT(blank,string_b%chars(i)) )THEN c_lle_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN IF( LLT(string_a(lb+1:la),blank) )THEN c_lle_s = .TRUE.; RETURN ELSEIF( LGT(string_a(lb+1:la),blank) )THEN c_lle_s = .FALSE.; RETURN ENDIF ENDIF c_lle_s = .TRUE. ENDFUNCTION c_lle_s !----- LGE procedures -------------------------------------------------------! FUNCTION s_lge_s(string_a,string_b) ! string_a>=string_b ISO-646 ordering type(VARYING_STRING),INTENT(IN) :: string_a,string_b LOGICAL :: s_lge_s ! Returns TRUE if strings are equal or if string_a follows string_b in the ! ISO 646 collating sequence. Otherwise the result is FALSE. INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LGT(string_a%chars(i),string_b%chars(i)) )THEN s_lge_s = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),string_b%chars(i)) )THEN s_lge_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LGT(blank,string_b%chars(i)) )THEN s_lge_s = .TRUE.; RETURN ELSEIF( LLT(blank,string_b%chars(i)) )THEN s_lge_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN DO i = lb+1,la IF( LGT(string_a%chars(i),blank) )THEN s_lge_s = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),blank) )THEN s_lge_s = .FALSE.; RETURN ENDIF ENDDO ENDIF s_lge_s = .TRUE. ENDFUNCTION s_lge_s FUNCTION s_lge_c(string_a,string_b) ! string_a>=string_b ISO-646 ordering type(VARYING_STRING),INTENT(IN) :: string_a CHARACTER(LEN=*),INTENT(IN) :: string_b LOGICAL :: s_lge_c INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LGT(string_a%chars(i),string_b(i:i)) )THEN s_lge_c = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),string_b(i:i)) )THEN s_lge_c = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN IF( LGT(blank,string_b(la+1:lb)) )THEN s_lge_c = .TRUE.; RETURN ELSEIF( LLT(blank,string_b(la+1:lb)) )THEN s_lge_c = .FALSE.; RETURN ENDIF ELSEIF( la > lb )THEN DO i = lb+1,la IF( LGT(string_a%chars(i),blank) )THEN s_lge_c = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),blank) )THEN s_lge_c = .FALSE.; RETURN ENDIF ENDDO ENDIF s_lge_c = .TRUE. ENDFUNCTION s_lge_c FUNCTION c_lge_s(string_a,string_b) ! string_a>=string_b ISO-646 ordering CHARACTER(LEN=*),INTENT(IN) :: string_a type(VARYING_STRING),INTENT(IN) :: string_b LOGICAL :: c_lge_s INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LGT(string_a(i:i),string_b%chars(i)) )THEN c_lge_s = .TRUE.; RETURN ELSEIF( LLT(string_a(i:i),string_b%chars(i)) )THEN c_lge_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LGT(blank,string_b%chars(i)) )THEN c_lge_s = .TRUE.; RETURN ELSEIF( LLT(blank,string_b%chars(i)) )THEN c_lge_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN IF( LGT(string_a(lb+1:la),blank) )THEN c_lge_s = .TRUE.; RETURN ELSEIF( LLT(string_a(lb+1:la),blank) )THEN c_lge_s = .FALSE.; RETURN ENDIF ENDIF c_lge_s = .TRUE. ENDFUNCTION c_lge_s !----- LGT procedures -------------------------------------------------------! FUNCTION s_lgt_s(string_a,string_b) ! string_a>string_b ISO-646 ordering type(VARYING_STRING),INTENT(IN) :: string_a,string_b LOGICAL :: s_lgt_s ! Returns TRUE if string_a follows string_b in the ISO 646 collating sequence. ! Otherwise the result is FALSE. The result is FALSE if both string_a and ! string_b are zero length. INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LGT(string_a%chars(i),string_b%chars(i)) )THEN s_lgt_s = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),string_b%chars(i)) )THEN s_lgt_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LGT(blank,string_b%chars(i)) )THEN s_lgt_s = .TRUE.; RETURN ELSEIF( LLT(blank,string_b%chars(i)) )THEN s_lgt_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN DO i = lb+1,la IF( LGT(string_a%chars(i),blank) )THEN s_lgt_s = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),blank) )THEN s_lgt_s = .FALSE.; RETURN ENDIF ENDDO ENDIF s_lgt_s = .FALSE. ENDFUNCTION s_lgt_s FUNCTION s_lgt_c(string_a,string_b) ! string_a>string_b ISO-646 ordering type(VARYING_STRING),INTENT(IN) :: string_a CHARACTER(LEN=*),INTENT(IN) :: string_b LOGICAL :: s_lgt_c INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LGT(string_a%chars(i),string_b(i:i)) )THEN s_lgt_c = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),string_b(i:i)) )THEN s_lgt_c = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN IF( LGT(blank,string_b(la+1:lb)) )THEN s_lgt_c = .TRUE.; RETURN ELSEIF( LLT(blank,string_b(la+1:lb)) )THEN s_lgt_c = .FALSE.; RETURN ENDIF ELSEIF( la > lb )THEN DO i = lb+1,la IF( LGT(string_a%chars(i),blank) )THEN s_lgt_c = .TRUE.; RETURN ELSEIF( LLT(string_a%chars(i),blank) )THEN s_lgt_c = .FALSE.; RETURN ENDIF ENDDO ENDIF s_lgt_c = .FALSE. ENDFUNCTION s_lgt_c FUNCTION c_lgt_s(string_a,string_b) ! string_a>string_b ISO-646 ordering CHARACTER(LEN=*),INTENT(IN) :: string_a type(VARYING_STRING),INTENT(IN) :: string_b LOGICAL :: c_lgt_s INTEGER :: ls,la,lb la = LEN(string_a); lb = LEN(string_b); ls = MIN(la,lb) DO i = 1,ls IF( LGT(string_a(i:i),string_b%chars(i)) )THEN c_lgt_s = .TRUE.; RETURN ELSEIF( LLT(string_a(i:i),string_b%chars(i)) )THEN c_lgt_s = .FALSE.; RETURN ENDIF ENDDO IF( la < lb )THEN DO i = la+1,lb IF( LGT(blank,string_b%chars(i)) )THEN c_lgt_s = .TRUE.; RETURN ELSEIF( LLT(blank,string_b%chars(i)) )THEN c_lgt_s = .FALSE.; RETURN ENDIF ENDDO ELSEIF( la > lb )THEN IF( LGT(string_a(lb+1:la),blank) )THEN c_lgt_s = .TRUE.; RETURN ELSEIF( LLT(string_a(lb+1:la),blank) )THEN c_lgt_s = .FALSE.; RETURN ENDIF ENDIF c_lgt_s = .FALSE. ENDFUNCTION c_lgt_s !----- Input string procedure -----------------------------------------------! SUBROUTINE get_d_eor(string,maxlen,iostat) type(VARYING_STRING),INTENT(OUT) :: string ! the string variable to be filled with ! characters read from the ! file connected to the default unit INTEGER,INTENT(IN),OPTIONAL :: maxlen ! if present indicates the maximum ! number of characters that will be ! read from the file INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! reads string from the default unit starting at next character in the file ! and terminating at the end of record or after maxlen characters. CHARACTER(LEN=80) :: buffer INTEGER :: ist,nch,toread,nb IF(PRESENT(maxlen))THEN toread=maxlen ELSE toread=HUGE(1) ENDIF string = "" ! clears return string DO ! repeatedly read buffer and add to string until EoR ! or maxlen reached IF(toread <= 0)EXIT nb=MIN(80,toread) READ(*,FMT='(A)',ADVANCE='NO',EOR=9999,SIZE=nch,IOSTAT=ist) buffer(1:nb) IF( ist /= 0 )THEN IF(PRESENT(iostat)) THEN iostat=ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during READ_STRING of varying string on default unit" STOP ENDIF ENDIF string = string //buffer(1:nb) toread = toread - nb ENDDO IF(PRESENT(iostat)) iostat = 0 RETURN 9999 string = string //buffer(1:nch) IF(PRESENT(iostat)) iostat = 0 ENDSUBROUTINE get_d_eor SUBROUTINE get_u_eor(unit,string,maxlen,iostat) INTEGER,INTENT(IN) :: unit ! identifies the input unit which must be ! connected for sequential formatted read type(VARYING_STRING),INTENT(OUT) :: string ! the string variable to be filled with ! characters read from the ! file connected to the unit INTEGER,INTENT(IN),OPTIONAL :: maxlen ! if present indicates the maximum ! number of characters that will be ! read from the file INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! reads string from unit starting at next character in the file and ! terminating at the end of record or after maxlen characters. CHARACTER(LEN=80) :: buffer INTEGER :: ist,nch,toread,nb IF(PRESENT(maxlen))THEN toread=maxlen ELSE toread=HUGE(1) ENDIF string="" ! clears return string DO ! repeatedly read buffer and add to string until EoR ! or maxlen reached IF(toread <= 0)EXIT nb=MIN(80,toread) READ(unit,FMT='(A)',ADVANCE='NO',EOR=9999,SIZE=nch,IOSTAT=ist) buffer(1:nb) IF( ist /= 0 )THEN IF(PRESENT(iostat)) THEN iostat=ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during READ_STRING of varying string on UNIT ",unit STOP ENDIF ENDIF string = string //buffer(1:nb) toread = toread - nb ENDDO IF(PRESENT(iostat)) iostat = 0 RETURN 9999 string = string //buffer(1:nch) IF(PRESENT(iostat)) iostat = 0 ENDSUBROUTINE get_u_eor SUBROUTINE get_d_tset_s(string,set,maxlen,iostat) type(VARYING_STRING),INTENT(OUT) :: string ! the string variable to be filled with ! characters read from the ! file connected to the default unit type(VARYING_STRING),INTENT(IN) :: set ! the set of characters which if found in ! the input terminate the read INTEGER,INTENT(IN),OPTIONAL :: maxlen ! if present indicates the maximum ! number of characters that will be ! read from the file INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! reads string from the default unit starting at next character in the file and ! terminating at the end of record, occurance of a character in set, ! or after reading maxlen characters. CHARACTER :: buffer ! characters must be read one at a time to detect ! first terminator character in set INTEGER :: ist,toread,lenset ist=0 lenset = LEN(set) IF(PRESENT(maxlen))THEN toread=maxlen ELSE toread=HUGE(1) ENDIF string = "" ! clears return string DO ! repeatedly read buffer and add to string until EoR ! or maxlen reached IF(toread <= 0)EXIT READ(*,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer IF( ist /= 0 )THEN IF(PRESENT(iostat)) THEN iostat=ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during READ_STRING of varying string on default unit" STOP ENDIF ENDIF ! check for occurance of set character in buffer DO j = 1,lenset IF(buffer == set%chars(j)) GOTO 9999 ENDDO string = string//buffer toread = toread - 1 ENDDO IF(PRESENT(iostat)) iostat = ist RETURN 9999 string = string//buffer IF(PRESENT(iostat)) iostat = ist ENDSUBROUTINE get_d_tset_s SUBROUTINE get_u_tset_s(unit,string,set,maxlen,iostat) INTEGER,INTENT(IN) :: unit ! identifies the input unit which must be ! connected for sequential formatted read type(VARYING_STRING),INTENT(OUT) :: string ! the string variable to be filled with ! characters read from the ! file connected to the unit type(VARYING_STRING),INTENT(IN) :: set ! the set of characters which if found in ! the input terminate the read INTEGER,INTENT(IN),OPTIONAL :: maxlen ! if present indicates the maximum ! number of characters that will be ! read from the file INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! reads string from unit starting at next character in the file and ! terminating at the end of record, occurance of a character in set, ! or after reading maxlen characters. CHARACTER :: buffer ! characters must be read one at a time to detect ! first terminator character in set INTEGER :: ist,toread,lenset ist=0 lenset = LEN(set) IF(PRESENT(maxlen))THEN toread=maxlen ELSE toread=HUGE(1) ENDIF string = "" ! clears return string DO ! repeatedly read buffer and add to string until EoR ! or maxlen reached IF(toread <= 0)EXIT READ(unit,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer IF( ist /= 0 )THEN IF(PRESENT(iostat)) THEN iostat=ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during READ_STRING of varying string on unit ",unit STOP ENDIF ENDIF ! check for occurance of set character in buffer DO j = 1,lenset IF(buffer == set%chars(j)) GOTO 9999 ENDDO string = string//buffer toread = toread - 1 ENDDO IF(PRESENT(iostat)) iostat = ist RETURN 9999 string = string//buffer IF(PRESENT(iostat)) iostat = ist ENDSUBROUTINE get_u_tset_s SUBROUTINE get_d_tset_c(string,set,maxlen,iostat) type(VARYING_STRING),INTENT(OUT) :: string ! the string variable to be filled with ! characters read from the ! file connected to the default unit CHARACTER(LEN=*),INTENT(IN) :: set ! the set of characters which if found in ! the input terminate the read INTEGER,INTENT(IN),OPTIONAL :: maxlen ! if present indicates the maximum ! number of characters that will be ! read from the file INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! reads string from the default unit starting at next character in the file and ! terminating at the end of record, occurance of a character in set, ! or after reading maxlen characters. CHARACTER :: buffer ! characters must be read one at a time to detect ! first terminator character in set INTEGER :: ist,toread,lenset ist=0 lenset = LEN(set) IF(PRESENT(maxlen))THEN toread=maxlen ELSE toread=HUGE(1) ENDIF string = "" ! clears return string DO ! repeatedly read buffer and add to string until EoR ! or maxlen reached IF(toread <= 0)EXIT READ(*,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer IF( ist /= 0 )THEN IF(PRESENT(iostat)) THEN iostat=ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during READ_STRING of varying string on default unit" STOP ENDIF ENDIF ! check for occurance of set character in buffer DO j = 1,lenset IF(buffer == set(j:j)) GOTO 9999 ENDDO string = string//buffer toread = toread - 1 ENDDO IF(PRESENT(iostat)) iostat = ist RETURN 9999 string = string//buffer IF(PRESENT(iostat)) iostat = ist ENDSUBROUTINE get_d_tset_c SUBROUTINE get_u_tset_c(unit,string,set,maxlen,iostat) INTEGER,INTENT(IN) :: unit ! identifies the input unit which must be ! connected for sequential formatted read type(VARYING_STRING),INTENT(OUT) :: string ! the string variable to be filled with ! characters read from the ! file connected to the unit CHARACTER(LEN=*),INTENT(IN) :: set ! the set of characters which if found in ! the input terminate the read INTEGER,INTENT(IN),OPTIONAL :: maxlen ! if present indicates the maximum ! number of characters that will be ! read from the file INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! reads string from unit starting at next character in the file and ! terminating at the end of record, occurance of a character in set, ! or after reading maxlen characters. CHARACTER :: buffer ! characters must be read one at a time to detect ! first terminator character in set INTEGER :: ist,toread,lenset ist=0 lenset = LEN(set) IF(PRESENT(maxlen))THEN toread=maxlen ELSE toread=HUGE(1) ENDIF string = "" ! clears return string DO ! repeatedly read buffer and add to string until EoR ! or maxlen reached IF(toread <= 0)EXIT READ(unit,FMT='(A)',ADVANCE='NO',EOR=9999,IOSTAT=ist) buffer IF( ist /= 0 )THEN IF(PRESENT(iostat)) THEN iostat=ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during READ_STRING of varying string on unit ",unit STOP ENDIF ENDIF ! check for occurance of set character in buffer DO j = 1,lenset IF(buffer == set(j:j)) GOTO 9999 ENDDO string = string//buffer toread = toread - 1 ENDDO IF(PRESENT(iostat)) iostat = ist RETURN 9999 string = string//buffer IF(PRESENT(iostat)) iostat = ist ENDSUBROUTINE get_u_tset_c !----- Output string procedures ----------------------------------------------! SUBROUTINE put_d_s(string,iostat) type(VARYING_STRING),INTENT(IN) :: string ! the string variable to be appended to ! the current record or to the start of ! the next record if there is no ! current record ! uses the default unit INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination INTEGER :: ist WRITE(*,FMT='(A)',ADVANCE='NO',IOSTAT=ist) CHAR(string) IF( ist /= 0 )THEN IF(PRESENT(iostat))THEN iostat = ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during WRITE_STRING of varying string on default unit" STOP ENDIF ENDIF IF(PRESENT(iostat)) iostat=0 ENDSUBROUTINE put_d_s SUBROUTINE put_u_s(unit,string,iostat) INTEGER,INTENT(IN) :: unit ! identifies the output unit which must ! be connected for sequential formatted ! write type(VARYING_STRING),INTENT(IN) :: string ! the string variable to be appended to ! the current record or to the start of ! the next record if there is no ! current record INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination WRITE(unit,FMT='(A)',ADVANCE='NO',IOSTAT=ist) CHAR(string) IF( ist /= 0 )THEN IF(PRESENT(iostat))THEN iostat = ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during WRITE_STRING of varying string on UNIT ",unit STOP ENDIF ENDIF IF(PRESENT(iostat)) iostat=0 ENDSUBROUTINE put_u_s SUBROUTINE put_d_c(string,iostat) CHARACTER(LEN=*),INTENT(IN) :: string ! the character variable to be appended to ! the current record or to the start of ! the next record if there is no ! current record ! uses the default unit INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination INTEGER :: ist WRITE(*,FMT='(A)',ADVANCE='NO',IOSTAT=ist) string IF( ist /= 0 )THEN IF(PRESENT(iostat))THEN iostat = ist RETURN ELSE WRITE(*,*) " Error No.",ist, & " during WRITE_STRING of character on default unit" STOP ENDIF ENDIF IF(PRESENT(iostat)) iostat=0 ENDSUBROUTINE put_d_c SUBROUTINE put_u_c(unit,string,iostat) INTEGER,INTENT(IN) :: unit ! identifies the output unit which must ! be connected for sequential formatted ! write CHARACTER(LEN=*),INTENT(IN) :: string ! the character variable to be appended to ! the current record or to the start of ! the next record if there is no ! current record INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination INTEGER :: ist WRITE(unit,FMT='(A)',ADVANCE='NO',IOSTAT=ist) string IF( ist /= 0 )THEN IF(PRESENT(iostat))THEN iostat = ist RETURN ELSE WRITE(*,*) " Error No.",ist," during WRITE_STRING of character on UNIT ",unit STOP ENDIF ENDIF IF(PRESENT(iostat)) iostat=0 ENDSUBROUTINE put_u_c SUBROUTINE putline_d_s(string,iostat) type(VARYING_STRING),INTENT(IN) :: string ! the string variable to be appended to ! the current record or to the start of ! the next record if there is no ! current record ! uses the default unit INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! appends the string to the current record and then ends the record ! leaves the file positioned after the record just completed which then ! becomes the previous and last record in the file. INTEGER :: ist WRITE(*,FMT='(A,/)',ADVANCE='NO',IOSTAT=ist) CHAR(string) IF( ist /= 0 )THEN IF(PRESENT(iostat))THEN iostat = ist; RETURN ELSE WRITE(*,*) " Error No.",ist, & " during WRITE_LINE of varying string on default unit" STOP ENDIF ENDIF IF(PRESENT(iostat)) iostat=0 ENDSUBROUTINE putline_d_s SUBROUTINE putline_u_s(unit,string,iostat) INTEGER,INTENT(IN) :: unit ! identifies the output unit which must ! be connected for sequential formatted ! write type(VARYING_STRING),INTENT(IN) :: string ! the string variable to be appended to ! the current record or to the start of ! the next record if there is no ! current record INTEGER,INTENT(OUT),OPTIONAL :: iostat ! if present used to return the status ! of the data transfer ! if absent errors cause termination ! appends the string to the current record and then ends the record ! leaves the file positioned after the record just completed which then ! becomes the previous and last record in the file. INTEGER :: ist WRITE(unit,FMT='(A,/)',ADVANCE='NO',IOSTAT=ist) CHAR(string) IF( ist /= 0 )THEN IF(PRESENT(iostat))THEN iostat = ist; RETURN ELSE WRITE(*,*) " Error No.",ist, & " during WRITE_LINE of varying string on UNIT",unit STOP ENDIF ENDIF IF(PRESENT(iostat)) iostat=0 ENDSUBROUTINE putline_u_s