C Copyright(c) 1997, Space Science and Engineering Center, UW-Madison C Refer to "McIDAS Software Acquisition and Distribution Policies" C in the file mcidas/data/license.txt C This is ddesub.for -- a collection of low-level DDE functions C *** $Id: ddesub.f,v 1.26 2019/03/27 20:56:40 daves Exp $ *** *| Name: *| m0tracearg - builds TRACE= string from command arguments *| *| Interface: *| integer function *| m0tracearg(character*(*) string) *| *| Input: *| none *| *| Input and Output: *| none *| *| Output: *| string - string containing TRACE= and a numeric value *| *| Return values: *| 0 - success *| -1 - unable to retrieve TRACE= value *| -2 - not enough room in destination string *| integer function m0tracearg(string) implicit none include 'fileparm.inc' character*(*) string character*(MAXPATHLENGTH) tmpstr integer value integer status integer length integer begchr integer endchr integer outlen integer nchars integer mccmdint status = mccmdint('TRA.CE',1,'Trace Flag',0,99,-99,value) if (status .lt. 0)then m0tracearg = -1 goto 999 endif write(tmpstr,FMT='(a6,i12)')'TRACE=',value call bsquez(tmpstr) outlen = nchars(tmpstr, begchr, endchr) length = len(string) if (outlen .gt. length)then m0tracearg = -2 goto 999 endif string = tmpstr m0tracearg = 0 999 continue return end *| Name: *| m0cxreq - transmit request to server for inbound data flow *| *| Interface: *| integer function *| m0cxreq( character*4 type, character*(*) text, integer ndata, *| integer data(*) , integer nbytes ) *| *| Input: *| type - 4 byte transaction name, for example AGET *| text - the text of the request passed to the server *| ndata - the number of bytes of binary data following the request *| this number is usually 0 *| data - array containing the arbitrary data, if any *| *| Input and Output: *| none *| *| Output: *| nbytes - the number of bytes in the first record returned from server *| *| Return values: *| 0 - success *| <0 - failure *| *| Remarks: *| This is used by API routines, to contact DDE servers *| *| Categories: *| DDE communications INTEGER FUNCTION M0CXREQ(TYPE,TEXT,NDATA,DATA,NBYTES) C CHARACTER*(*) TEXT CHARACTER*4 TYPE INTEGER M0CXOUT, M0CXCLOS, M0CXREAD, M0CXWRIT, DATA(*) CHARACTER*72 errmsg COMMON/C1BLOK/J(64),ITIME PARAMETER (INTERVAL=10000) ! TEN SECONDS PARAMETER (MAXRETRY=10) ! max retries before giving up PARAMETER (NOSERVICE=-100) ! error number for service not available NRETRY=0 C C------TRY TO GET TRANSACTION STARTED 1 JRET=M0CXOUT( TYPE, TEXT, NDATA) C C------BAD RETURN HERE IMPLIES COULDNT FIND INTERFACE MODULE IF( JRET.NE.0 ) THEN IRET=-98 errmsg='Local interface module cannot be found' CALL MOVCW(errmsg, J(44)) J(43)=IRET GOTO 1000 ENDIF C C------SEND ARBITRARY DATA, IF ANY IF(NDATA.NE.0) THEN IRET=M0CXWRIT( NDATA, DATA ) IF (IRET.NE.0) GOTO 1000 ENDIF C---------------------------------------------------------------------- C C NOW WE ARE READY TO START READING C C--- GET BLOCK HEADER ( 4-BYTE LENGTH OF BLOCK ) IRET=M0CXREAD( 4, J(41) ) IF( IRET.NE.0 ) GOTO 1000 C C--- ACCOUNT FOR BYTE ORDER CALL SWBYT4( J(41), 1 ) NBYTES=J(41) C C--- EXIT IF THERE IS DATA WHICH WILL BE READ BY THE CALLER IF(NBYTES.NE.0) GOTO 1000 C C--- READ REPLY TRAILER IRET=M0CXREAD( 92, J(42) ) IF( IRET.NE.0 ) GOTO 1000 C C-----SWAP BYTES TO PUT IN NATIVE BYTE ORDER CALL SWBYT4( J(43), 1 ) IRET=J(43) II=M0CXCLOS(0) C------for error -100, there may be retries IF(IRET.EQ.NOSERVICE) THEN NRETRY=NRETRY+1 IF(NRETRY.GE.MAXRETRY) GOTO 1000 CALL MCSLEEP(INTERVAL) CALL DDEST('DDE retry number ',NRETRY) GOTO 1 ENDIF C 1000 M0CXREQ=IRET RETURN END *| Name: *| m0cxout - low level request to server *| *| Interface: *| integer function *| m0cxreq( character*4 type, character*(*) text, integer nbytes) *| *| Input: *| type - 4 byte transaction name, for example AGET *| text - the text of the request passed to the server *| nbytes - the number of bytes of binary data which will be sent out *| this number is usually 0 *| *| Input and Output: *| none *| *| Output: *| none *| *| Return values: *| 0 - success *| <0 - failure *| *| Remarks: *| This is used by mainly by m0cxreq, it can be used by API *| level routines when a lot of data is sent out, and m0cxreq *| is being bypassed *| *| Categories: *| DDE communications INTEGER FUNCTION M0CXOUT(TYPE, TEXT, NBYTES) C include 'gridparm.inc' CHARACTER*(*) TEXT CHARACTER*4 TYPE CHARACTER*120 A CHARACTER*(MAXGRDRQSTLEN) R CHARACTER*72 errmsg INTEGER M0CXADDR, M0CXCOMM DIMENSION IBUF(125) COMMON/C1BLOK/J(64),I1 EQUIVALENCE( R, IBUF(1) ) C CALL ZEROW(64,J) errmsg = ' ' C J(9) =LIT(TYPE) C R=TEXT CALL BSQUEZ(R) C C-----WILL TEXT FIT IN 120 BYTES? IF(R(121:).NE.' ') THEN NLENG=LEN_TRIM(R) ELSE NLENG=0 ENDIF A=R C C------MOVE BEGINNING OF TEXT IN ANYWAY, TO BE LOOKED AT BY ROUTING STUFF CALL MOVCW(A,J(11)) C C--- DETERMINE ADDRESS OF SERVER, BASED ON NATURE OF REQUEST IRET=M0CXADDR( J ) IF(IRET.NE.0) THEN IRET=-103 errmsg='The DDE route could not be determined' GOTO 1000 ENDIF C C-----TOTAL OUTPUT BYTES J(10)=NBYTES+NLENG CALL SWBYT4(J(10),1) C C-----IF REQUEST WOULDN'T FIT IN 120 BYTES, CHANGE FORMAT OF BLOCK IF(NLENG.NE.0) THEN J(11)=NLENG CALL SWBYT4(J(11),1) CALL ZEROW(29,J(12)) ENDIF C C--- SPAWN COMMUNICATIONS PROCESS, SEND REQUEST HEADER CALL GETTIM( I1) IRET=M0CXCOMM( J ) C IF(IRET.NE.0) THEN IRET=-98 errmsg='Local interface module cannot be found' ELSE C----------TRANSMIT STRING, IF IT DIDNT FIT IF(NLENG.NE.0) THEN IRET=M0CXWRIT(NLENG,IBUF) ENDIF ENDIF 1000 M0CXOUT=IRET J(43)=IRET CALL MOVCW(errmsg, J(44)) RETURN END *| Name: *| m0cxaddr - figure out the IP address of a request *| *| Interface: *| integer function *| m0cxaddr( integer block(64) ) *| *| Input: *| none *| *| Input and Output: *| block - the transaction control block. this routine *| adds several fields, including the foreign IP address *| *| *| Output: *| none *| *| Return values: *| 0 - success *| <0 - failure *| *| Remarks: *| This is used by m0cxout *| *| Categories: *| DDE communications INTEGER FUNCTION M0CXADDR( BLOCK ) C Add the IP address of a DDE request to the DDE control block (jmb) C also add port, user, project and (default) password C This version uses a 1-level (group only) name to address binding C with the default that all unknown names are local C the object group name is found as the first parameter of the DDE text INTEGER BLOCK(64) ! DDE request block character*12 cfz C---------Local variables INTEGER LOCAL(64) ! Local copy of block, to allow equivalence INTEGER RET ! Return value of function INTEGER RET2 ! Temporary return value INTEGER ISTAT ! Status return INTEGER IPADD ! IP address INTEGER PORT ! Port for DDE service INTEGER USER ! USERS INITIALS INTEGER PROJECT ! McIDAS project number INTEGER P1,P2,P3 ! password INTEGER MCCCHECK ! Check MCCOMPRESS integer value CHARACTER*4 VERB ! DDE action CHARACTER*120 COMAND ! DDE text string CHARACTER*80 KEY ! Lookup string CHARACTER*80 VALUE ! Answer of lookup CHARACTER*80 NAMEVALUE ! Copy of answer of lookup CHARACTER*12 COMPRESS ! Value of MCCOMPRESS keyword CHARACTER*12 ENV_COMPRESS ! Environment variable of MCCOMPRESS C------Function references INTEGER M0LBADDRN ! IP address of loopback INTEGER M0CXIPAD ! IP address from text INTEGER INDEX ! FORTRAN substring finder INTEGER ISDGCH ! FORTRAN determine if string all digits C-------Define interesting fields of local block EQUIVALENCE ( IPADD, LOCAL(1) ) EQUIVALENCE ( PORT, LOCAL(2) ) EQUIVALENCE ( USER, LOCAL(4) ) EQUIVALENCE (PROJECT, LOCAL(5) ) EQUIVALENCE ( P1, LOCAL(6) ) EQUIVALENCE ( P2, LOCAL(7) ) EQUIVALENCE ( P3, LOCAL(8) ) EQUIVALENCE ( VERB, LOCAL(9) ) EQUIVALENCE ( COMAND, LOCAL(11) ) RET=0 C-------Get local copy of block CALL MOVW( 64, BLOCK, LOCAL ) C------- First: Check environment variable ISTAT = M0GETENV('MCCOMPRESS', ENV_COMPRESS) CALL MCUPCASE(ENV_COMPRESS) c m0getenv returns -1 if the env. variable does not exist -> no compression c m0getenv returns 0 if the env. variable is set -> use compress c if the return string is GZIP or gzip -> use gzip c if the return string is NONE or none -> no compression c if the return string is port number 112, 500, 503 -> use that port c if the return string is an integer above 1023 -> use that port c MSTAT = MCSTRTOINT(ENV_COMPRESS,MCCCHECK) MSTAT = 0 MCCCHECK = 0 c only call MCSTRTOINT if string contains all digits IF(ISDGCH(ENV_COMPRESS) .EQ. 1) THEN MSTAT = MCSTRTOINT(ENV_COMPRESS,MCCCHECK) ENDIF IF(ISTAT .EQ. -1) ENV_COMPRESS = 'NONE' IF(ISTAT .EQ. 0 .AND. .NOT. ( & (ENV_COMPRESS .EQ. 'GZIP') .OR. & (ENV_COMPRESS .EQ. 'NONE') .OR. & (ENV_COMPRESS .EQ. '112') .OR. & (ENV_COMPRESS .EQ. '500') .OR. & (ENV_COMPRESS .EQ. '503'))) ENV_COMPRESS = 'COMPRESS' IF(MSTAT .EQ. 100 .AND. MCCCHECK .GT. 1023) THEN WRITE(ENV_COMPRESS,'(I5)') MCCCHECK ENDIF C---- Second: Check if UC(-41) was set by a previous command IF(LUC(-41) .NE. 0) THEN PORT=LUC(-41) IF(PORT .EQ. 1) ENV_COMPRESS = 'NONE' IF(PORT .EQ. 2) ENV_COMPRESS = 'COMPRESS' IF(PORT .EQ. 3) ENV_COMPRESS = 'GZIP' IF(PORT .GT. 1023) WRITE(ENV_COMPRESS,'(I5)') PORT ENDIF C---- Third: Check keyword on command line ISTAT = MCCMDSTR('MCC.OMPRESS', 1, ENV_COMPRESS, COMPRESS) CALL MCUPCASE(COMPRESS) c---Port is either compression type or specific port. c---mcserv will deal with it c MSTAT = MCSTRTOINT(COMPRESS, PORT) MSTAT = 0 PORT = 0 c only call MCSTRTOINT if string contains all digits IF(ISDGCH(COMPRESS) .EQ. 1) THEN MSTAT = MCSTRTOINT(COMPRESS, PORT) ENDIF IF(MSTAT .NE. 100) PORT = 0 IF(MSTAT .EQ. 100 .AND. PORT .LE. 1023) PORT = 1 IF(COMPRESS .EQ. 'NONE') PORT = 1 IF(COMPRESS .EQ. 'COMPRESS') PORT = 2 IF(COMPRESS .EQ. 'GZIP') PORT = 3 IF( PORT .EQ. 0) THEN CALL EDEST('MCCOMPRESS may only be set to: '// & 'NONE, COMPRESS, or GZIP',0) CALL EDEST('done',0) CALL M0EXIT(1) RETURN ENDIF c--- If the port is already in UC, use that value IF(LUC(-41) .NE. 0) THEN IF(PORT .EQ. 1) COMPRESS = 'NONE' IF(PORT .EQ. 2) COMPRESS = 'COMPRESS' IF(PORT .EQ. 3) COMPRESS = 'GZIP' IF(PORT .GT. 1023) COMPRESS= 'NONE' ENDIF c--- Store in UC(-41) CALL PUC(PORT, -41) CALL DDEST('ENV_COMPRESS: '//ENV_COMPRESS,0) CALL DDEST('COMPRESS: '//COMPRESS,0) CALL DDEST('PORT: ',PORT) IF(PORT .EQ. 500 .OR. PORT .EQ. 503 .OR. PORT .GT. 1023) then CALL DDEST('ADDE request using port ',PORT) ELSE CALL DDEST('ADDE request using port 112 with compression: ' * //COMPRESS,0) ENDIF C-------Add in our data, with default IP address of local IPADD = M0LBADDRN() USER = LUC(2) PROJECT=LUC(1) P1=0 P2=0 P3=0 C-------numeric fields in network byte order CALL SWBYT4( PROJECT, 1) CALL SWBYT4( PORT, 1) C------Create key,using first parameter of COMAND KEY = 'ADDE_ROUTE_'//COMAND(1:INDEX(COMAND,' ')) C-------Special case of transaction for NAMEL command IF ( VERB .EQ. 'LWPR' ) THEN KEY = 'ADDE_ROUTE_'//COMAND(5:INDEX(COMAND,' ')) ENDIF C-------Look up in table CALL MCATRGET( KEY, VALUE ) C-------For NAV and TEXT commands, give a second try into the table IF ( VERB(1:1) .EQ. 'T' .AND. VALUE .EQ. ' ' ) THEN CALL MCATRGET( 'ADDE_ROUTE_TEXT', VALUE ) ELSEIF ( VERB(1:1) .EQ. 'N' .AND. VALUE .EQ. ' ' ) THEN CALL MCATRGET( 'ADDE_ROUTE_NAV', VALUE ) ENDIF c-------Save the name value for later use in tunneling NAMEVALUE = VALUE C---------An alpha value should be looked up to see if a HOST_ entry is there IF( VALUE(1:1) .GE. 'A' .AND. VALUE(1:1) .LE. 'Z' ) THEN CALL MCATRGET( 'HOST_'//VALUE, VALUE ) ENDIF C--------if a value found, use its address IF ( VALUE .NE. ' ' ) THEN RET =M0CXIPAD( VALUE, IPADD ) ENDIF c-----setup an ssh tunnel if it has been configured via dataloc c-----this will push loopback and a local port into the connection block RET2 = M0TUNNEL(NAMEVALUE, LOCAL) C-----return modified block, and status of address conversion, or default CALL MOVW( 64, LOCAL, BLOCK ) M0CXADDR = RET RETURN END *| Name: *| m0cxfin - end a transaction after all data has been read *| *| Interface: *| subroutine *| m0cxfin *| *| Input: *| none *| *| Input and Output: *| none *| *| Output: *| none *| *| Return values: *| none *| *| Remarks: *| This is used by API routines *| it returns resources and drops the TCPIP connection *| *| Categories: *| DDE communications INTEGER FUNCTION M0CXFIN() C-------called to bind off a transaction after all input has been read CHARACTER*72 B INTEGER M0CXCLOS, M0CXREAD, m0cxerms COMMON/C1BLOK/J(64),I1 C-----READ MESSAGE TRAILER IRET=M0CXREAD(92,J(42)) C-----CPU TIME CALL SWBYT4(J(42),1) X=J(42) X=X*.01 C-----ELAPSED TIME CALL GETTIM(I2) Y=(FTIME(I2)-FTIME(I1))*3600. WRITE(B,200) X,Y 200 FORMAT('Server CPU time=',F6.2,' sec, transaction elapsed time=', &F5.0) C-----DEBUG MESSAGE about CPU usage IF(J(42).NE.0.AND.J(43).EQ.0) CALL DDEST(B,0) C------BIND OFF RESOURCES, CLOSE PIPES II=M0CXCLOS(0) C------YOU ARE DONE, UNLESS J(43) SHOWS AN ERROR MESSAGE C-----SQUEEZE BLANKS OUT OF SERVER ERROR MESSAGE CALL MOVWC(J(44),B) CALL BSQUEZ(B) C-----MAKE ERROR CODE HAVE RIGHT BYTE ORDER CALL SWBYT4(J(43),1) CALL MOVCW(B,J(44)) m0cxfin = j(43) GOTO 1000 C-----CALL CXERMS IF YOU WANT THE ERROR MESSAGE FROM THE SERVER *| Name: *| m0cxerms - output the error message sent by the server *| *| Interface: *| subroutine *| m0cxerms *| *| Input: *| none *| *| Input and Output: *| none *| *| Output: *| none *| *| Return values: *| none *| *| Remarks: *| This is used by API routines *| it outputs the error message sent by a server. *| this means that the API level can control whether the message *| is sent or not, depending on whether this is called *| *| Categories: *| DDE communications ENTRY M0CXERMS IER=J(43) IF(IER.EQ.0) RETURN CALL MOVWC(J(44),B) call ddest('Server returned error number ', ier) call cleanc(b) call edest(b,0) m0cxerms = 0 1000 RETURN END